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

[cmucl-cvs] CMUCL commit: src/contrib/asdf (asdf.lisp)
by Raymond Toy 30 Mar '11

30 Mar '11

Date: Wednesday, March 30, 2011 @ 00:27:51 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf Modified: asdf.lisp Update to asdf 2.014.1 to fix an issue with SUBDIRECTORIES function on cmucl. -----------+ asdf.lisp | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.13 src/contrib/asdf/asdf.lisp:1.14 --- src/contrib/asdf/asdf.lisp:1.13 Mon Mar 28 13:23:39 2011 +++ src/contrib/asdf/asdf.lisp Wed Mar 30 00:27:50 2011 @@ -1,5 +1,5 @@ ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.014: Another System Definition Facility. +;;; This is ASDF 2.014.1: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -99,7 +99,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.014") + (asdf-version "2.014.1") (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -3521,9 +3521,9 @@ (let* ((directory (ensure-directory-pathname directory)) #-(or cormanlisp genera) (wild (merge-pathnames* - #-(or abcl allegro lispworks scl) + #-(or abcl allegro cmu lispworks scl) *wild-directory* - #+(or abcl allegro lispworks scl) "*.*" + #+(or abcl allegro cmu lispworks scl) "*.*" directory)) (dirs #-(or cormanlisp genera) @@ -3532,7 +3532,7 @@ #+mcl '(:directories t)))) #+cormanlisp (cl::directory-subdirs directory) #+genera (fs:directory-list directory)) - #+(or abcl allegro genera lispworks scl) + #+(or abcl allegro cmu genera lispworks scl) (dirs (remove-if-not #+abcl #'extensions:probe-directory #+allegro #'excl:probe-directory #+lispworks #'lw:file-directory-p

1 0

[cmucl-cvs] CMUCL commit: src/contrib/asdf (asdf.lisp)
by Raymond Toy 28 Mar '11

28 Mar '11

Date: Monday, March 28, 2011 @ 13:23:40 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf Modified: asdf.lisp Update to asdf 2.014. -----------+ asdf.lisp | 226 ++++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 136 insertions(+), 90 deletions(-) Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.12 src/contrib/asdf/asdf.lisp:1.13 --- src/contrib/asdf/asdf.lisp:1.12 Thu Mar 24 12:40:59 2011 +++ src/contrib/asdf/asdf.lisp Mon Mar 28 13:23:39 2011 @@ -1,5 +1,5 @@ ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.013: Another System Definition Facility. +;;; This is ASDF 2.014: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -68,6 +68,22 @@ (in-package :asdf) +;;; Strip out formating that is not supported on Genera. +(defmacro compatfmt (format) + #-genera format + #+genera + (let ((r '(("~@<" . "") + ("; ~@;" . "; ") + ("~3i~_" . "") + ("~@:>" . "") + ("~:>" . "")))) + (dolist (i r) + (loop :for found = (search (car i) format) :while found :do + (setf format (concatenate 'simple-string (subseq format 0 found) + (cdr i) + (subseq format (+ found (length (car i)))))))) + format)) + ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more near the end of the file. @@ -83,18 +99,18 @@ ;; "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.013") + (asdf-version "2.014") (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* - "~&; Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" - existing-version asdf-version)) + (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") + existing-version asdf-version)) (labels ((present-symbol-p (symbol package) - (member (nth-value 1 (find-symbol symbol package)) '(:internal :external))) + (member (nth-value 1 (find-sym symbol package)) '(:internal :external))) (present-symbols (package) ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera (let (l) @@ -422,7 +438,7 @@ (defun* normalize-pathname-directory-component (directory) (cond - #-(or sbcl cmu) + #-(or cmu sbcl scl) ((stringp directory) `(:absolute ,directory) directory) #+gcl ((and (consp directory) (stringp (first directory))) @@ -431,7 +447,7 @@ (and (consp directory) (member (first directory) '(:absolute :relative)))) directory) (t - (error "Unrecognized pathname directory component ~S" directory)))) + (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory)))) (defun* merge-pathname-directory-components (specified defaults) (let ((directory (normalize-pathname-directory-component specified))) @@ -461,6 +477,9 @@ 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)) + #+scl + (ext:resolve-pathname specified defaults) + #-scl (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (normalize-pathname-directory-component (pathname-directory specified))) @@ -509,15 +528,10 @@ (defun* last-char (s) (and (stringp s) (plusp (length s)) (char s (1- (length s))))) -(defun* errfmt (out format-string &rest format-args) - (declare (dynamic-extent format-args)) - (apply #'format out - #-genera (format nil "~~@<~A~~:>" format-string) #+genera format-string - format-args)) - + (defun* asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) - (apply #'errfmt *verbose-out* format-string format-args)) + (apply #'format *verbose-out* format-string format-args)) (defun* split-string (string &key max (separator '(#\Space #\Tab))) "Split STRING into a list of components separated by @@ -569,7 +583,7 @@ pathnames." (check-type s string) (when (find #\: s) - (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s)) + (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s)) (let* ((components (split-string s :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) @@ -577,7 +591,7 @@ (if (equal (first-char s) #\/) (progn (when force-relative - (error "absolute pathname designator not allowed: ~S" s)) + (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s)) (values :absolute (cdr components))) (values :relative nil)) (values :relative components)) @@ -648,9 +662,9 @@ ((stringp pathspec) (ensure-directory-pathname (pathname pathspec))) ((not (pathnamep pathspec)) - (error "Invalid pathname designator ~S" pathspec)) + (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec)) ((wild-pathname-p pathspec) - (error "Can't reliably convert wild pathname ~S" pathspec)) + (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec)) ((directory-pathname-p pathspec) pathspec) (t @@ -716,10 +730,10 @@ (error () (error "Unable to find out user ID"))))))) (defun* pathname-root (pathname) - (make-pathname :host (pathname-host pathname) - :device (pathname-device pathname) - :directory '(:absolute) - :name nil :type nil :version nil)) + (make-pathname :directory '(:absolute) + :name nil :type nil :version nil + :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun* find-symbol* (s p) (find-symbol (string s) p)) @@ -744,7 +758,7 @@ (when (typep p 'logical-pathname) (return p)) (let ((found (probe-file* p))) (when found (return found))) - #-(or sbcl cmu) (when (stringp directory) (return p)) + #-(or cmu sbcl scl) (when (stringp directory) (return p)) (when (not (eq :absolute (car directory))) (return p)) (let ((sofar (probe-file* (pathname-root p)))) (unless sofar (return p)) @@ -792,10 +806,12 @@ (defun* wilden (path) (merge-pathnames* *wild-path* path)) +#-scl (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) +#-scl (defun* directorize-pathname-host-device (pathname) (let* ((root (pathname-root pathname)) (wild-root (wilden root)) @@ -815,6 +831,31 @@ :directory `(:absolute ,@path)))) (translate-pathname absolute-pathname wild-root (wilden new-base)))))) +#+scl +(defun* directorize-pathname-host-device (pathname) + (let ((scheme (ext:pathname-scheme pathname)) + (host (pathname-host pathname)) + (port (ext:pathname-port pathname)) + (directory (pathname-directory pathname))) + (flet ((not-unspecific (component) + (and (not (eq component :unspecific)) component))) + (cond ((or (not-unspecific port) + (and (not-unspecific host) (plusp (length host))) + (not-unspecific scheme)) + (let ((prefix "")) + (when (not-unspecific port) + (setf prefix (format nil ":~D" port))) + (when (and (not-unspecific host) (plusp (length host))) + (setf prefix (concatenate 'string host prefix))) + (setf prefix (concatenate 'string ":" prefix)) + (when (not-unspecific scheme) + (setf prefix (concatenate 'string scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + (t + pathname))))) + ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. (defgeneric* find-system (system &optional error-p)) @@ -930,7 +971,8 @@ ((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))) + (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") + m ,(asdf-version))) (when (member 'components-by-name added) (compute-module-components-by-name m)) (when (typep m 'system) @@ -969,25 +1011,26 @@ ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) - (apply #'errfmt s (format-control c) (format-arguments c))))) + (apply #'format s (format-control c) (format-arguments c))))) (define-condition load-system-definition-error (system-definition-error) ((name :initarg :name :reader error-name) (pathname :initarg :pathname :reader error-pathname) (condition :initarg :condition :reader error-condition)) (:report (lambda (c s) - (errfmt s "Error while trying to load definition for system ~A from pathname ~A: ~A" + (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") (error-name c) (error-pathname c) (error-condition c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components)) (:report (lambda (c s) - (errfmt s "Circular dependency: ~S" (circular-dependency-components c))))) + (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") + (circular-dependency-components c))))) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) - (errfmt s "Error while defining system: multiple components are given same name ~A" + (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>") (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) @@ -1008,7 +1051,7 @@ ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (errfmt s "erred while invoking ~A on ~A" + (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>") (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) @@ -1020,14 +1063,14 @@ (format :reader condition-format :initarg :format) (arguments :reader condition-arguments :initarg :arguments :initform nil)) (:report (lambda (c s) - (errfmt s "~? (will be skipped)" + (format s (compatfmt "~@<~? (will be skipped)~@:>") (condition-format c) (list* (condition-form c) (condition-location c) (condition-arguments c)))))) (define-condition invalid-source-registry (invalid-configuration warning) - ((format :initform "invalid source registry ~S~@[ in ~S~]~@{ ~@?~}"))) + ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) (define-condition invalid-output-translation (invalid-configuration warning) - ((format :initform "invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}"))) + ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) (defclass component () ((name :accessor component-name :initarg :name :documentation @@ -1091,7 +1134,7 @@ ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) - (format s "~A, required by ~A" + (format s (compatfmt "~@<~A, required by ~A~@:>") (call-next-method c nil) (missing-required-by c))) (defun* sysdef-error (format &rest arguments) @@ -1101,13 +1144,13 @@ ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s "component ~S not found~@[ in ~A~]" + (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>") (missing-requires c) (when (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~]" + (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>") (missing-requires c) (missing-version c) (when (missing-parent c) @@ -1167,7 +1210,7 @@ (component-relative-pathname component) (pathname-directory-pathname (component-parent-pathname component))))) (unless (or (null pathname) (absolute-pathname-p pathname)) - (error "Invalid relative pathname ~S for component ~S" + (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>") pathname (component-find-path component))) (setf (slot-value component 'absolute-pathname) pathname) pathname))) @@ -1236,7 +1279,7 @@ (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) - (t (sysdef-error "invalid component designator ~A" name)))) + (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name)))) (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) @@ -1329,8 +1372,8 @@ (restart-case (let* ((*print-circle* nil) (message - (errfmt nil - "While searching for system ~S: ~S evaluated to ~S which is not a directory." + (format nil + (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>") system dir defaults))) (error message)) (remove-entry-from-registry () @@ -1338,7 +1381,7 @@ (push dir to-remove)) (coerce-entry-to-directory () :report (lambda (s) - (errfmt s "Coerce entry to ~a, replace ~a and continue." + (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>") (ensure-directory-pathname defaults) dir)) (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) ;; cleanup @@ -1374,7 +1417,7 @@ (or (and pathname (probe-file* pathname) (file-write-date pathname)) (progn (when (and pathname *asdf-verbose*) - (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." + (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>") pathname)) 0))) @@ -1391,9 +1434,8 @@ :name name :pathname pathname :condition condition)))) (let ((*package* package)) - (asdf-message - "~&; Loading system definition from ~A into ~A~%" - pathname package) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") + pathname package) (load pathname))) (delete-package package)))) @@ -1418,9 +1460,10 @@ (error 'missing-component :requires name))))))) (defun* register-system (name system) - (asdf-message "~&; Registering ~A as ~A~%" system name) - (setf (gethash (coerce-name name) *defined-systems*) - (cons (get-universal-time) system))) + (setf name (coerce-name name)) + (assert (equal name (component-name system))) + (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) + (setf (gethash 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) @@ -1496,11 +1539,6 @@ (declare (ignorable s)) (source-file-explicit-type component)) -(defun* merge-component-name-type (name &key type defaults) - ;; For backwards compatibility only, for people using internals. - ;; Will be removed in a future release, e.g. 2.014. - (coerce-pathname name :type type :defaults defaults)) - (defun* coerce-pathname (name &key type defaults) "coerce NAME into a PATHNAME. When given a string, portably decompose it into a relative pathname: @@ -1515,9 +1553,8 @@ ;; to the below make-pathname, which may crucially matter to people using ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. ;; NOTE that the host and device slots will be taken from the defaults, - ;; but that should only matter if you either (a) use absolute pathnames, or - ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of - ;; ASDF:MERGE-PATHNAMES* + ;; but that should only matter if you later merge relative pathnames with + ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* (etypecase name ((or null pathname) name) @@ -1535,12 +1572,13 @@ (values filename type)) (t (split-name-type filename))) - (let* ((defaults (pathname (or defaults *default-pathname-defaults*))) - (host (pathname-host defaults)) - (device (pathname-device defaults))) - (make-pathname :directory `(,relative ,@path) - :name name :type type - :host host :device device))))))) + (make-pathname :directory `(,relative ,@path) :name name :type type + :defaults (or defaults *default-pathname-defaults*))))))) + +(defun* merge-component-name-type (name &key type defaults) + ;; For backwards compatibility only, for people using internals. + ;; Will be removed in a future release, e.g. 2.014. + (coerce-pathname name :type type :defaults defaults)) (defmethod component-relative-pathname ((component component)) (coerce-pathname @@ -1764,7 +1802,7 @@ required-op required-c required-v)) (retry () :report (lambda (s) - (errfmt s "Retry loading component ~S." required-c)) + (format s "~@<Retry loading component ~3i~_~S.~@:>" required-c)) :test (lambda (c) (or (null c) @@ -1808,7 +1846,7 @@ (when (find (second d) *features* :test 'string-equal) (dep op (third d) nil))) (t - (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d)))))) + (error (compatfmt "~@<Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d)))))) flag)))) (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes @@ -1933,7 +1971,7 @@ (defmethod perform ((operation operation) (c source-file)) (sysdef-error - "required method PERFORM not implemented for operation ~A, component ~A" + (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>") (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) @@ -1944,7 +1982,8 @@ (asdf-message "~&;;; ~A~%" (operation-description operation component))) (defmethod operation-description (operation component) - (format nil "~A on component ~S" (class-of operation) (component-find-path component))) + (format nil (compatfmt "~@<~A on component ~S~@:>") + (class-of operation) (component-find-path component))) ;;;; ------------------------------------------------------------------------- ;;;; compile-op @@ -1994,14 +2033,14 @@ (when warnings-p (case (operation-on-warnings operation) (:warn (warn - "COMPILE-FILE warned while performing ~A on ~A." + (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>") operation c)) (:error (error 'compile-warned :component c :operation operation)) (:ignore nil))) (when failure-p (case (operation-on-failure operation) (:warn (warn - "COMPILE-FILE failed while performing ~A on ~A." + (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>") operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) @@ -2103,7 +2142,8 @@ (defmethod operation-description ((operation load-op) component) (declare (ignorable operation)) - (format nil "loading component ~S" (component-find-path component))) + (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>") + (component-find-path component))) ;;;; ------------------------------------------------------------------------- @@ -2146,7 +2186,8 @@ (defmethod operation-description ((operation load-source-op) component) (declare (ignorable operation)) - (format nil "loading component ~S" (component-find-path component))) + (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>") + (component-find-path component))) ;;;; ------------------------------------------------------------------------- @@ -2197,11 +2238,12 @@ (retry () :report (lambda (s) - (errfmt s "Retry ~A." (operation-description op component)))) + (format s (compatfmt "~@<Retry ~A.~@:>") + (operation-description op component)))) (accept () :report (lambda (s) - (errfmt s "Continue, treating ~A as having been successful." + (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") (operation-description op component))) (setf (gethash (type-of op) (component-operation-times component)) @@ -2287,6 +2329,7 @@ (default-directory)))) (defmacro defsystem (name &body options) + (setf name (coerce-name name)) (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) defsystem-depends-on &allow-other-keys) options @@ -2296,7 +2339,7 @@ ;; we recur when trying to find an existing system of the same name ;; to reuse options (e.g. pathname) from ,@(loop :for system :in defsystem-depends-on - :collect `(load-system ,system)) + :collect `(load-system ',(coerce-name system))) (let ((s (system-registered-p ',name))) (cond ((and s (eq (type-of (cdr s)) ',class)) (setf (car s) (get-universal-time))) @@ -2357,7 +2400,7 @@ (defun* sysdef-error-component (msg type name value) (sysdef-error (concatenate 'string msg - "~&The value specified for ~(~A~) ~A is ~S") + (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) type name value)) (defun* check-component-input (type name weakly-depends-on @@ -2688,13 +2731,13 @@ (t (apply #'warn fstring args) "unknown")))) (let ((lisp (maybe-warn (implementation-type) - "No implementation feature found in ~a." + (compatfmt "~@<No implementation feature found in ~a.~@:>") *implementation-features*)) (os (maybe-warn (first-feature *os-features*) - "No os feature found in ~a." *os-features*)) + (compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*)) (arch (or #-clisp (maybe-warn (first-feature *architecture-features*) - "No architecture feature found in ~a." + (compatfmt "~@<No architecture feature found in ~a.~@:>") *architecture-features*))) (version (maybe-warn (lisp-version-string) "Don't know how to get Lisp implementation version."))) @@ -2794,14 +2837,15 @@ :finally (unless (= inherit 1) (report-invalid-form invalid-form-reporter - :arguments (list "One and only one of ~S or ~S is required" + :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>") :inherit-configuration :ignore-inherited-configuration))) (return (nreverse x)))) (defun* validate-configuration-file (file validator &key description) (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) - (error "One and only one form allowed for ~A. Got: ~S~%" description forms)) + (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%") + description forms)) (funcall validator (car forms) :location file))) (defun* hidden-file-p (pathname) @@ -2922,7 +2966,7 @@ (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 "pathname ~S is not relative to ~S" s super)) + (error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super)) (merge-pathnames* s super))) (defvar *here-directory* nil @@ -2964,7 +3008,7 @@ (wilden r) r))) (unless (absolute-pathname-p s) - (error "Not an absolute pathname ~S" s)) + (error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s)) s)) (defun* resolve-location (x &key directory wilden) @@ -3036,7 +3080,7 @@ ((or (null string) (equal string "")) '(:output-translations :inherit-configuration)) ((not (stringp string)) - (error "environment string isn't: ~S" string)) + (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string)) ((eql (char string 0) #\") (parse-output-translations-string (read-from-string string) :location location)) ((eql (char string 0) #\() @@ -3056,7 +3100,8 @@ (setf source nil)) ((equal "" s) (when inherit - (error "only one inherited configuration allowed: ~S" string)) + (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") + string)) (setf inherit t) (push :inherit-configuration directives)) (t @@ -3064,7 +3109,8 @@ (setf start (1+ i)) (when (> start end) (when source - (error "Uneven number of components in source to destination mapping ~S" string)) + (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>") + string)) (unless inherit (push :ignore-inherited-configuration directives)) (return `(:output-translations ,@(nreverse directives))))))))) @@ -3215,7 +3261,7 @@ ((eq destination t) path) ((not (pathnamep destination)) - (error "invalid destination")) + (error "Invalid destination")) ((not (absolute-pathname-p destination)) (translate-pathname path absolute-source (merge-pathnames* destination root))) (root @@ -3546,7 +3592,7 @@ ((or (null string) (equal string "")) '(:source-registry :inherit-configuration)) ((not (stringp string)) - (error "environment string isn't: ~S" string)) + (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string)) ((find (char string 0) "\"(") (validate-source-registry-form (read-from-string string) :location location)) (t @@ -3560,7 +3606,8 @@ (cond ((equal "" s) ; empty element: inherit (when inherit - (error "only one inherited configuration allowed: ~S" string)) + (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") + string)) (setf inherit t) (push ':inherit-configuration directives)) ((ends-with s "//") @@ -3756,13 +3803,12 @@ ((style-warning #'muffle-warning) (missing-component (constantly nil)) (error #'(lambda (e) - (errfmt *error-output* "ASDF could not load ~(~A~) because ~A.~%" + (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%") name e)))) - (let* ((*verbose-out* (make-broadcast-stream)) + (let ((*verbose-out* (make-broadcast-stream)) (system (find-system (string-downcase name) nil))) (when system - (load-system system) - t)))) + (load-system system))))) #+(or abcl clisp clozure cmu ecl sbcl) (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))

1 0

[cmucl-cvs] CMUCL commit: src/compiler (main.lisp)
by Raymond Toy 28 Mar '11

28 Mar '11

Date: Monday, March 28, 2011 @ 08:07:35 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler Modified: main.lisp Second return value of compile-file should be true if style-warnings exist. Issue noted by Douglas Crosher, cmucl-imp, 2011-03-23. -----------+ main.lisp | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) Index: src/compiler/main.lisp diff -u src/compiler/main.lisp:1.159 src/compiler/main.lisp:1.160 --- src/compiler/main.lisp:1.159 Fri Sep 24 08:12:05 2010 +++ src/compiler/main.lisp Mon Mar 28 08:07:34 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.159 2010-09-24 12:12:05 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/compiler/main.lisp,v 1.160 2011-03-28 12:07:34 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1907,8 +1907,12 @@ ;; Hack around filesystem race condition... (or (probe-file output-file-pathname) output-file-pathname) nil) - (if (member error-severity '(:warning :error)) t nil) - ;; FIXME in the following we should not return t for a STYLE-WARNING + ;; CLHS says the second return value "is false if no + ;; conditions of type error or warning were detected by + ;; the compiler". This should include style-warnings. + (not (null error-severity)) + ;; FIXME in the following we should not return t for a + ;; STYLE-WARNING (if (member error-severity '(:warning :error)) t nil)))) ;;;; COMPILE and UNCOMPILE:

1 0

[cmucl-cvs] CMUCL commit: src/contrib/asdf (asdf.lisp)
by Raymond Toy 24 Mar '11

24 Mar '11

Date: Thursday, March 24, 2011 @ 12:40:59 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf Modified: asdf.lisp Update to upstream released version 2.013. -----------+ asdf.lisp | 870 +++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 520 insertions(+), 350 deletions(-) Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.11 src/contrib/asdf/asdf.lisp:1.12 --- src/contrib/asdf/asdf.lisp:1.11 Wed Dec 8 18:57:02 2010 +++ src/contrib/asdf/asdf.lisp Thu Mar 24 12:40:59 2011 @@ -1,5 +1,5 @@ -;;; -*- mode: common-lisp; package: asdf; -*- -;;; This is ASDF: Another System Definition Facility. +;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- +;;; This is ASDF 2.013: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -10,9 +10,9 @@ ;;; trouble using it, or find bugs, you may want to check at the ;;; location above for a more recent version (and for documentation ;;; and test files, if your copy came without them) before reporting -;;; bugs. There are usually two "supported" revisions - the git HEAD -;;; is the latest development version, whereas the revision tagged -;;; RELEASE may be slightly older but is considered `stable' +;;; bugs. There are usually two "supported" revisions - the git master +;;; branch is the latest development version, whereas the git release +;;; branch may be slightly older but is considered `stable' ;;; -- LICENSE START ;;; (This is the MIT / X Consortium license as taken from @@ -47,7 +47,7 @@ #+xcvb (module ()) -(cl:in-package :cl-user) +(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user) #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this @@ -55,14 +55,16 @@ ;;; make package if it doesn't exist yet. ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. (unless (find-package :asdf) - (make-package :asdf :use '(:cl))) + (make-package :asdf :use '(:common-lisp))) ;;; Implementation-dependent tweaks ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) - #+ecl (require :cmp)) + #+(and ecl (not ecl-bytecmp)) (require :cmp) + #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*) + #+(or unix cygwin) (pushnew :asdf-unix *features*)) (in-package :asdf) @@ -74,25 +76,35 @@ (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (let* (;; For bug reporting sanity, please always bump this version when you modify this file. + ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version + ;; can help you do these changes in synch (look at the source for documentation). + ;; Relying on its automation, the version is now redundantly present on top of 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") + ;; "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.013") (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* - "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%" + "~&; Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" existing-version asdf-version)) (labels - ((unlink-package (package) + ((present-symbol-p (symbol package) + (member (nth-value 1 (find-symbol symbol package)) '(:internal :external))) + (present-symbols (package) + ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera + (let (l) + (do-symbols (s package) + (when (present-symbol-p s package) (push s l))) + (reverse l))) + (unlink-package (package) (let ((u (find-package package))) (when u - (ensure-unintern u - (loop :for s :being :each :present-symbol :in u :collect s)) + (ensure-unintern u (present-symbols u)) (loop :for p :in (package-used-by-list u) :do (unuse-package u p)) (delete-package u)))) @@ -146,7 +158,7 @@ (let ((formerly-exported-symbols nil) (bothly-exported-symbols nil) (newly-exported-symbols nil)) - (loop :for sym :being :each :external-symbol :in package :do + (do-external-symbols (sym package) (if (member sym export :test 'string-equal) (push sym bothly-exported-symbols) (push sym formerly-exported-symbols))) @@ -184,7 +196,8 @@ (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system - #:apply-output-translations #:translate-pathname* #:resolve-location) + #:apply-output-translations #:translate-pathname* #:resolve-location + #:compile-file*) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector @@ -276,6 +289,7 @@ #:remove-entry-from-registry #:clear-configuration + #:*output-translations-parameter* #:initialize-output-translations #:disable-output-translations #:clear-output-translations @@ -285,6 +299,7 @@ #:compile-file-pathname* #:enable-asdf-binary-locations-compatibility #:*default-source-registries* + #:*source-registry-parameter* #:initialize-source-registry #:compute-source-registry #:clear-source-registry @@ -306,6 +321,7 @@ ;; #:length=n-p ;; #:find-symbol* #:merge-pathnames* + #:coerce-pathname #:pathname-directory-pathname #:read-file-forms ;; #:remove-keys @@ -317,6 +333,7 @@ #:subdirectories #:truenamize #:while-collecting))) + #+genera (import 'scl:boolean :asdf) (setf *asdf-version* asdf-version *upgraded-p* (if existing-version (cons existing-version *upgraded-p*) @@ -328,7 +345,7 @@ (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.000\")." +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")." *asdf-version*) (defvar *resolve-symlinks* t @@ -403,6 +420,41 @@ (when pathname (make-pathname :name nil :type nil :version nil :defaults pathname))) +(defun* normalize-pathname-directory-component (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 pathname directory component ~S" directory)))) + +(defun* merge-pathname-directory-components (specified defaults) + (let ((directory (normalize-pathname-directory-component specified))) + (ecase (first directory) + ((nil) defaults) + (:absolute specified) + (:relative + (let ((defdir (normalize-pathname-directory-component defaults)) + (reldir (cdr directory))) + (cond + ((null defdir) + directory) + ((not (eq :back (first reldir))) + (append defdir reldir)) + (t + (loop :with defabs = (first defdir) + :with defrev = (reverse (rest defdir)) + :while (and (eq :back (car reldir)) + (or (and (eq :absolute defabs) (null defrev)) + (stringp (car defrev)))) + :do (pop reldir) (pop defrev) + :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. @@ -411,19 +463,7 @@ (when (null defaults) (return-from merge-pathnames* specified)) (let* ((specified (pathname specified)) (defaults (pathname defaults)) - (directory (pathname-directory specified)) - (directory - (cond - #-(or sbcl cmu scl) - ((stringp directory) `(:absolute ,directory) directory) - #+gcl - ((and (consp directory) (not (member (first directory) '(:absolute :relative)))) - `(:relative ,@directory)) - ((or (null directory) - (and (consp directory) (member (first directory) '(:absolute :relative)))) - directory) - (t - (error "Unrecognized directory component ~S in pathname ~S" directory specified)))) + (directory (normalize-pathname-directory-component (pathname-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)))) @@ -433,28 +473,30 @@ (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) - ((nil) - (values (pathname-host defaults) - (pathname-device defaults) - (pathname-directory defaults) - (unspecific-handler defaults))) ((:absolute) (values (pathname-host specified) (pathname-device specified) directory (unspecific-handler specified))) - ((:relative) + ((nil :relative) (values (pathname-host defaults) (pathname-device defaults) - (if (pathname-directory defaults) - (append (pathname-directory defaults) (cdr directory)) - directory) + (merge-pathname-directory-components directory (pathname-directory defaults)) (unspecific-handler defaults)))) (make-pathname :host host :device device :directory directory :name (funcall unspecific-handler name) :type (funcall unspecific-handler type) :version (funcall unspecific-handler version)))))) +(defun* pathname-parent-directory-pathname (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME, TYPE and VERSION components" + (when pathname + (make-pathname :name nil :type nil :version nil + :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) + + (define-modify-macro appendf (&rest args) append "Append onto list") ;; only to be used on short lists. @@ -467,9 +509,15 @@ (defun* last-char (s) (and (stringp s) (plusp (length s)) (char s (1- (length s))))) +(defun* errfmt (out format-string &rest format-args) + (declare (dynamic-extent format-args)) + (apply #'format out + #-genera (format nil "~~@<~A~~:>" format-string) #+genera format-string + format-args)) + (defun* asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) - (apply #'format *verbose-out* format-string format-args)) + (apply #'errfmt *verbose-out* format-string format-args)) (defun* split-string (string &key max (separator '(#\Space #\Tab))) "Split STRING into a list of components separated by @@ -496,7 +544,7 @@ ;; Giving :unspecific as argument to make-pathname is not portable. ;; See CLHS make-pathname and 19.2.2.2.3. ;; We only use it on implementations that support it. - (or #+(or ccl ecl gcl lispworks sbcl) :unspecific))) + (or #+(or clozure gcl lispworks sbcl) :unspecific))) (destructuring-bind (name &optional (type unspecific)) (split-string filename :max 2 :separator ".") (if (equal name "") @@ -533,7 +581,8 @@ (values :absolute (cdr components))) (values :relative nil)) (values :relative components)) - (setf components (remove "" components :test #'equal)) + (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components)) + (setf components (substitute :back ".." components :test #'equal)) (cond ((equal last-comp "") (values relative components nil)) ; "" already removed @@ -553,16 +602,27 @@ :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) - (#+(or abcl clisp) ext:getenv - #+allegro sys:getenv - #+clozure ccl:getenv - #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=))) - #+ecl si:getenv - #+gcl system:getenv - #+lispworks lispworks:environment-variable - #+sbcl sb-ext:posix-getenv - x)) + (declare (ignorable x)) + #+(or abcl clisp) (ext:getenv x) + #+allegro (sys:getenv x) + #+clozure (ccl:getenv x) + #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) + #+ecl (si:getenv x) + #+gcl (system:getenv x) + #+genera nil + #+lispworks (lispworks:environment-variable x) + #+mcl (ccl:with-cstrs ((name x)) + (let ((value (_getenv name))) + (unless (ccl:%null-ptr-p value) + (ccl:%get-cstring value)))) + #+sbcl (sb-ext:posix-getenv x) + #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl) + (error "getenv not available on your implementation")) (defun* directory-pathname-p (pathname) "Does PATHNAME represent a directory? @@ -600,6 +660,11 @@ :name nil :type nil :version nil :defaults pathspec)))) +#+genera +(unless (fboundp 'ensure-directories-exist) + (defun ensure-directories-exist (path) + (fs:create-directories-recursively (pathname path)))) + (defun* absolute-pathname-p (pathspec) (and (typep pathspec '(or pathname string)) (eq :absolute (car (pathname-directory (pathname pathspec)))))) @@ -627,7 +692,7 @@ :until (eq form eof) :collect form))) -#-(and (or win32 windows mswindows mingw32) (not cygwin)) +#+asdf-unix (progn #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>")) @@ -667,13 +732,13 @@ (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" (block nil - (when (typep p 'logical-pathname) (return p)) + (when (typep p '(or null logical-pathname)) (return p)) (let* ((p (merge-pathnames* p)) (directory (pathname-directory p))) (when (typep p 'logical-pathname) (return p)) @@ -705,7 +770,9 @@ (defun* resolve-symlinks (path) #-allegro (truenamize path) - #+allegro (excl:pathname-resolve-symbolic-links path)) + #+allegro (if (typep path 'logical-pathname) + path + (excl:pathname-resolve-symbolic-links path))) (defun* default-directory () (truenamize (pathname-directory-pathname *default-pathname-defaults*))) @@ -713,24 +780,32 @@ (defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) +(defparameter *wild-file* + (make-pathname :name :wild :type :wild :version :wild :directory nil)) +(defparameter *wild-directory* + (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)) +(defparameter *wild-inferiors* + (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil)) (defparameter *wild-path* - (make-pathname :directory '(:relative :wild-inferiors) - :name :wild :type :wild :version :wild)) + (merge-pathnames *wild-file* *wild-inferiors*)) (defun* wilden (path) (merge-pathnames* *wild-path* path)) +(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) + (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) + (last-char (namestring foo)))) + (defun* directorize-pathname-host-device (pathname) (let* ((root (pathname-root pathname)) (wild-root (wilden root)) (absolute-pathname (merge-pathnames* pathname root)) - (foo (make-pathname :directory '(:absolute "FOO") :defaults root)) - (separator (last-char (namestring foo))) + (separator (directory-separator-for-host root)) (root-namestring (namestring root)) (root-string (substitute-if #\/ - (lambda (x) (or (eql x #\:) - (eql x separator))) + #'(lambda (x) (or (eql x #\:) + (eql x separator))) root-namestring))) (multiple-value-bind (relative path filename) (component-name-to-pathname-components root-string :force-directory t) @@ -849,24 +924,21 @@ ;;;; ------------------------------------------------------------------------- ;;; 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))) + (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)))))) + (when (typep m 'system) + (when (member 'source-file added) + (%set-system-source-file + (probe-asd (component-name m) (component-pathname m)) m) + (when (equal (component-name m) "asdf") + (setf (component-version m) *asdf-version*)))))))) ;;;; ------------------------------------------------------------------------- ;;;; Classes, Conditions @@ -886,7 +958,10 @@ duplicate-names-name error-component error-operation module-components module-components-by-name - circular-dependency-components) + circular-dependency-components + condition-arguments condition-form + condition-format condition-location + coerce-name) (ftype (function (t t) t) (setf module-components-by-name))) @@ -894,26 +969,26 @@ ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) - (apply #'format s (format-control c) (format-arguments c))))) + (apply #'errfmt s (format-control c) (format-arguments c))))) (define-condition load-system-definition-error (system-definition-error) ((name :initarg :name :reader error-name) (pathname :initarg :pathname :reader error-pathname) (condition :initarg :condition :reader error-condition)) (:report (lambda (c s) - (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>" - (error-name c) (error-pathname c) (error-condition c))))) + (errfmt s "Error while trying to load definition for system ~A from pathname ~A: ~A" + (error-name c) (error-pathname c) (error-condition c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components)) (:report (lambda (c s) - (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c))))) + (errfmt s "Circular dependency: ~S" (circular-dependency-components c))))) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) - (format s "~@<Error while defining system: multiple components are given same name ~A~@:>" - (duplicate-names-name c))))) + (errfmt s "Error while defining system: multiple components are given same name ~A" + (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) @@ -933,19 +1008,37 @@ ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s "~@<erred while invoking ~A on ~A~@:>" - (error-operation c) (error-component c))))) + (errfmt s "erred while invoking ~A on ~A" + (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) +(define-condition invalid-configuration () + ((form :reader condition-form :initarg :form) + (location :reader condition-location :initarg :location) + (format :reader condition-format :initarg :format) + (arguments :reader condition-arguments :initarg :arguments :initform nil)) + (:report (lambda (c s) + (errfmt s "~? (will be skipped)" + (condition-format c) + (list* (condition-form c) (condition-location c) + (condition-arguments c)))))) +(define-condition invalid-source-registry (invalid-configuration warning) + ((format :initform "invalid source registry ~S~@[ in ~S~]~@{ ~@?~}"))) +(define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform "invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}"))) + (defclass component () ((name :accessor component-name :initarg :name :documentation "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) - ;; 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 + (description :accessor component-description :initarg :description) + (long-description :accessor component-long-description :initarg :long-description) + ;; This one below is used by POIU - http://www.cliki.net/poiu + ;; a parallelizing extension of ASDF that compiles in multiple parallel + ;; slave processes (forked on demand) and loads in the master process. + ;; Maybe in the future ASDF may use it internally instead of in-order-to. (load-dependencies :accessor component-load-dependencies :initform nil) ;; In the ASDF object model, dependencies exist between *actions* ;; (an action is a pair of operation and component). They are represented @@ -964,6 +1057,7 @@ ;; 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! + ;; See our ASDF 2 paper for more complete explanations. (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) (do-first :initform nil :initarg :do-first @@ -991,13 +1085,13 @@ (defmethod print-object ((c component) stream) (print-unreadable-object (c stream :type t :identity nil) - (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c)))) + (format stream "~{~S~^ ~}" (component-find-path c)))) ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) - (format s "~@<~A, required by ~A~@:>" + (format s "~A, required by ~A" (call-next-method c nil) (missing-required-by c))) (defun* sysdef-error (format &rest arguments) @@ -1007,13 +1101,13 @@ ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s "~@<component ~S not found~@[ in ~A~]~@:>" + (format s "component ~S not found~@[ in ~A~]" (missing-requires c) (when (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~]~@:>" + (format s "component ~S does not match version ~A~@[ in ~A~]" (missing-requires c) (missing-version c) (when (missing-parent c) @@ -1090,9 +1184,10 @@ new-value) (defclass system (module) - ((description :accessor system-description :initarg :description) - (long-description - :accessor system-long-description :initarg :long-description) + (;; description and long-description are now available for all component's, + ;; but now also inherited from component, but we add the legacy accessor + (description :accessor system-description :initarg :description) + (long-description :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) (licence :accessor system-licence :initarg :licence @@ -1141,7 +1236,7 @@ (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) - (t (sysdef-error "~@<invalid component designator ~A~@:>" name)))) + (t (sysdef-error "invalid component designator ~A" name)))) (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) @@ -1151,22 +1246,19 @@ Note that this does NOT in any way cause the code of the system to be unloaded." ;; There is no "unload" operation in Common Lisp, and a general such operation ;; cannot be portably written, considering how much CL relies on side-effects - ;; of global data structures. - ;; Note that this does a setf gethash instead of a remhash - ;; this way there remains a hint in the *defined-systems* table - ;; that the system was loaded at some point. - (setf (gethash (coerce-name name) *defined-systems*) nil)) + ;; to global data structures. + (remhash (coerce-name name) *defined-systems*)) (defun* map-systems (fn) "Apply FN to each defined system. FN should be a function of one argument. It will be called with an object of type asdf:system." - (maphash (lambda (_ datum) - (declare (ignore _)) - (destructuring-bind (_ . def) datum + (maphash #'(lambda (_ datum) (declare (ignore _)) - (funcall fn def))) + (destructuring-bind (_ . def) datum + (declare (ignore _)) + (funcall fn def))) *defined-systems*)) ;;; for the sake of keeping things reasonably neat, we adopt a @@ -1178,7 +1270,7 @@ (defun* system-definition-pathname (system) (let ((system-name (coerce-name system))) (or - (some (lambda (x) (funcall x system-name)) + (some #'(lambda (x) (funcall x system-name)) *system-definition-search-functions*) (let ((system-pair (system-registered-p system-name))) (and system-pair @@ -1207,15 +1299,15 @@ :defaults defaults :version :newest :case :local :name name :type "asd"))) - (when (probe-file file) + (when (probe-file* file) (return file))) - #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) + #+(and asdf-windows (not clisp)) (let ((shortcut (make-pathname :defaults defaults :version :newest :case :local :name (concatenate 'string name ".asd") :type "lnk"))) - (when (probe-file shortcut) + (when (probe-file* shortcut) (let ((target (parse-windows-shortcut shortcut))) (when target (return (pathname target))))))))) @@ -1237,8 +1329,8 @@ (restart-case (let* ((*print-circle* nil) (message - (format nil - "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>" + (errfmt nil + "While searching for system ~S: ~S evaluated to ~S which is not a directory." system dir defaults))) (error message)) (remove-entry-from-registry () @@ -1246,8 +1338,8 @@ (push dir to-remove)) (coerce-entry-to-directory () :report (lambda (s) - (format s "Coerce entry to ~a, replace ~a and continue." - (ensure-directory-pathname defaults) dir)) + (errfmt s "Coerce entry to ~a, replace ~a and continue." + (ensure-directory-pathname defaults) dir)) (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) ;; cleanup (dolist (dir to-remove) @@ -1279,7 +1371,7 @@ ;; and we can survive and we will continue the planning ;; as if the file were very old. ;; (or should we treat the case in a different, special way?) - (or (and pathname (probe-file pathname) (file-write-date pathname)) + (or (and pathname (probe-file* pathname) (file-write-date pathname)) (progn (when (and pathname *asdf-verbose*) (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." @@ -1289,27 +1381,34 @@ (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p)) +(defun load-sysdef (name pathname) + ;; Tries to load system definition with canonical NAME from PATHNAME. + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname + :condition condition)))) + (let ((*package* package)) + (asdf-message + "~&; Loading system definition from ~A into ~A~%" + pathname package) + (load pathname))) + (delete-package package)))) + (defmethod find-system ((name string) &optional (error-p t)) (catch 'find-system - (let* ((in-memory (system-registered-p name)) + (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk (on-disk (system-definition-pathname name))) (when (and on-disk (or (not in-memory) - (< (car in-memory) (safe-file-write-date on-disk)))) - (let ((package (make-temporary-package))) - (unwind-protect - (handler-bind - ((error (lambda (condition) - (error 'load-system-definition-error - :name name :pathname on-disk - :condition condition)))) - (let ((*package* package)) - (asdf-message - "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%" - on-disk *package*) - (load on-disk))) - (delete-package package)))) - (let ((in-memory (system-registered-p name))) + ;; don't reload if it's already been loaded, + ;; or its filestamp is in the future which means some clock is skewed + ;; and trying to load might cause an infinite loop. + (< (car in-memory) (safe-file-write-date on-disk) (get-universal-time)))) + (load-sysdef name on-disk)) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk (cond (in-memory (when on-disk @@ -1319,7 +1418,7 @@ (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))) @@ -1340,7 +1439,8 @@ (throw 'find-system system)))) (defun* sysdef-find-asdf (name) - (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated. + ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. + (find-system-fallback name "asdf" :version *asdf-version*)) ;;;; ------------------------------------------------------------------------- @@ -1397,6 +1497,20 @@ (source-file-explicit-type component)) (defun* merge-component-name-type (name &key type defaults) + ;; For backwards compatibility only, for people using internals. + ;; Will be removed in a future release, e.g. 2.014. + (coerce-pathname name :type type :defaults defaults)) + +(defun* coerce-pathname (name &key type defaults) + "coerce NAME into a PATHNAME. +When given a string, portably decompose it into a relative pathname: +#\\/ separates subdirectories. The last #\\/-separated string is as follows: +if TYPE is NIL, its last #\\. if any separates name and type from from type; +if TYPE is a string, it is the type, and the whole string is the name; +if TYPE is :DIRECTORY, the string is a directory component; +if the string is empty, it's a directory. +Any directory named .. is read as :BACK. +Host, device and version components are taken from DEFAULTS." ;; The defaults are required notably because they provide the default host ;; to the below make-pathname, which may crucially matter to people using ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. @@ -1405,10 +1519,10 @@ ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of ;; ASDF:MERGE-PATHNAMES* (etypecase name - (pathname + ((or null pathname) name) (symbol - (merge-component-name-type (string-downcase name) :type type :defaults defaults)) + (coerce-pathname (string-downcase name) :type type :defaults defaults)) (string (multiple-value-bind (relative path filename) (component-name-to-pathname-components name :force-directory (eq type :directory) @@ -1429,7 +1543,7 @@ :host host :device device))))))) (defmethod component-relative-pathname ((component component)) - (merge-component-name-type + (coerce-pathname (or (slot-value component 'relative-pathname) (component-name component)) :type (source-file-type component (component-system component)) @@ -1537,18 +1651,18 @@ (defmethod component-self-dependencies ((o operation) (c component)) (let ((all-deps (component-depends-on o c))) - (remove-if-not (lambda (x) - (member (component-name c) (cdr x) :test #'string=)) + (remove-if-not #'(lambda (x) + (member (component-name c) (cdr x) :test #'string=)) all-deps))) (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) (self-deps (component-self-dependencies operation c))) (if self-deps - (mapcan (lambda (dep) - (destructuring-bind (op name) dep - (output-files (make-instance op) - (find-component parent name)))) + (mapcan #'(lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) self-deps) ;; no previous operations needed? I guess we work with the ;; original source file, then @@ -1602,8 +1716,8 @@ ;; than one second of filesystem time (or just crosses the ;; second). So that's cool. (and - (every #'probe-file in-files) - (every #'probe-file out-files) + (every #'probe-file* in-files) + (every #'probe-file* out-files) (>= (earliest-out) (latest-in)))))))) @@ -1650,14 +1764,13 @@ required-op required-c required-v)) (retry () :report (lambda (s) - (format s "~@<Retry loading component ~S.~@:>" - (component-find-path required-c))) + (errfmt s "Retry loading component ~S." required-c)) :test (lambda (c) - (or (null c) - (and (typep c 'missing-dependency) - (equalp (missing-requires c) - required-c)))))))) + (or (null c) + (and (typep c 'missing-dependency) + (equalp (missing-requires c) + required-c)))))))) (defun* do-dep (operation c collect op dep) ;; type of arguments uncertain: @@ -1820,7 +1933,7 @@ (defmethod perform ((operation operation) (c source-file)) (sysdef-error - "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>" + "required method PERFORM not implemented for operation ~A, component ~A" (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) @@ -1843,7 +1956,7 @@ (on-failure :initarg :on-failure :accessor operation-on-failure :initform *compile-file-failure-behaviour*) (flags :initarg :flags :accessor compile-op-flags - :initform #-ecl nil #+ecl '(:system-p t)))) + :initform nil))) (defun output-file (operation component) "The unique output file of performing OPERATION on COMPONENT" @@ -1852,25 +1965,18 @@ (first files))) (defmethod perform :before ((operation compile-op) (c source-file)) - (map nil #'ensure-directories-exist (output-files operation c))) - -#+ecl -(defmethod perform :after ((o compile-op) (c cl-source-file)) - ;; Note how we use OUTPUT-FILES to find the binary locations - ;; This allows the user to override the names. - (let* ((files (output-files o c)) - (object (first files)) - (fasl (second files))) - (c:build-fasl fasl :lisp-files (list object)))) + (loop :for file :in (asdf:output-files operation c) + :for pathname = (if (typep file 'logical-pathname) + (translate-logical-pathname file) + file) + :do (ensure-directories-exist pathname))) (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) (get-universal-time))) -(declaim (ftype (function ((or pathname string) - &rest t &key (:output-file t) &allow-other-keys) - (values t t t)) - compile-file*)) +(defvar *compile-op-compile-file-function* 'compile-file* + "Function used to compile lisp files.") ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy @@ -1883,19 +1989,19 @@ (*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-file* source-file :output-file output-file + (apply *compile-op-compile-file-function* source-file :output-file output-file (compile-op-flags operation)) (when warnings-p (case (operation-on-warnings operation) (:warn (warn - "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>" + "COMPILE-FILE warned while performing ~A on ~A." operation c)) (:error (error 'compile-warned :component c :operation operation)) (:ignore nil))) (when failure-p (case (operation-on-failure operation) (:warn (warn - "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>" + "COMPILE-FILE failed while performing ~A on ~A." operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) @@ -1905,10 +2011,8 @@ (defmethod output-files ((operation compile-op) (c cl-source-file)) (declare (ignorable operation)) (let ((p (lispize-pathname (component-pathname c)))) - #-:broken-fasl-loader - (list (compile-file-pathname p #+ecl :type #+ecl :object) - #+ecl (compile-file-pathname p :type :fasl)) - #+:broken-fasl-loader (list p))) + #-broken-fasl-loader (list (compile-file-pathname p)) + #+broken-fasl-loader (list p))) (defmethod perform ((operation compile-op) (c static-file)) (declare (ignorable operation c)) @@ -1934,11 +2038,7 @@ (defclass load-op (basic-load-op) ()) (defmethod perform ((o load-op) (c cl-source-file)) - (map () #'load - #-ecl (input-files o c) - #+ecl (loop :for i :in (input-files o c) - :unless (string= (pathname-type i) "fas") - :collect (compile-file-pathname (lispize-pathname i))))) + (map () #'load (input-files o c))) (defmethod perform-with-restarts (operation component) (perform operation component)) @@ -2031,10 +2131,10 @@ (declare (ignorable o)) (let ((what-would-load-op-do (cdr (assoc 'load-op (component-in-order-to c))))) - (mapcar (lambda (dep) - (if (eq (car dep) 'load-op) - (cons 'load-source-op (cdr dep)) - dep)) + (mapcar #'(lambda (dep) + (if (eq (car dep) 'load-op) + (cons 'load-source-op (cdr dep)) + dep)) what-would-load-op-do))) (defmethod operation-done-p ((o load-source-op) (c source-file)) @@ -2097,12 +2197,12 @@ (retry () :report (lambda (s) - (format s "~@<Retry ~A.~@:>" (operation-description op component)))) + (errfmt s "Retry ~A." (operation-description op component)))) (accept () :report (lambda (s) - (format s "~@<Continue, treating ~A as having been successful.~@:>" - (operation-description op component))) + (errfmt s "Continue, treating ~A as having been successful." + (operation-description op component))) (setf (gethash (type-of op) (component-operation-times component)) (get-universal-time)) @@ -2180,7 +2280,9 @@ ;; 3. taken from the *default-pathname-defaults* via default-directory (let* ((file-pathname (load-pathname)) (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) - (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname)) + (or (and pathname-supplied-p + (merge-pathnames* (coerce-pathname pathname :type :directory) + directory-pathname)) directory-pathname (default-directory)))) @@ -2223,7 +2325,7 @@ (and (eq type :file) (or (module-default-component-class parent) (find-class *default-component-class*))) - (sysdef-error "~@<don't recognize component type ~A~@:>" type))) + (sysdef-error "don't recognize component type ~A" type))) (defun* maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. @@ -2280,8 +2382,8 @@ ;; this is inefficient as most of the stored ;; methods will not be for this particular gf ;; But this is hardly performance-critical - (lambda (m) - (remove-method (symbol-function name) m)) + #'(lambda (m) + (remove-method (symbol-function name) m)) (component-inline-methods component))) ;; clear methods, then add the new ones (setf (component-inline-methods component) nil)) @@ -2408,7 +2510,7 @@ exit-code) #+clisp ;XXX not exactly *verbose-out*, I know - (ext:run-shell-command command :output :terminal :wait t) + (or (ext:run-shell-command command :output :terminal :wait t) 0) #+clozure (nth-value 1 @@ -2482,7 +2584,7 @@ (defun* system-relative-pathname (system name &key type) (merge-pathnames* - (merge-component-name-type name :type type) + (coerce-pathname name :type type) (system-source-directory system))) @@ -2493,13 +2595,13 @@ ;;; Initially stolen from SLIME's SWANK, hacked since. (defparameter *implementation-features* - '((:acl :allegro) - (:lw :lispworks) - (:digitool) ; before clozure, so it won't get preempted by ccl + '((:abcl :armedbear) + (:acl :allegro) + (:mcl :digitool) ; before clozure, so it won't get preempted by ccl (:ccl :clozure) (:corman :cormanlisp) - (:abcl :armedbear) - :sbcl :cmu :clisp :gcl :ecl :scl)) + (:lw :lispworks) + :clisp :cmu :ecl :gcl :sbcl :scl :symbolics)) (defparameter *os-features* '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows @@ -2507,7 +2609,8 @@ (:linux :linux-target) ;; for GCL at least, must appear before :bsd. (:macosx :darwin :darwin-target :apple) :freebsd :netbsd :openbsd :bsd - :unix)) + :unix + :genera)) (defparameter *architecture-features* '((:amd64 :x86-64 :x86_64 :x8664-target) @@ -2519,7 +2622,8 @@ :sparc64 (:sparc32 :sparc) (:arm :arm-target) - (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7))) + (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7) + :imach)) (defun* lisp-version-string () (let ((s (lisp-implementation-version))) @@ -2537,24 +2641,26 @@ (:+ics "")) (if (member :64bit *features*) "-64bit" "")) #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) - #+clisp (subseq s 0 (position #\space s)) + #+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) - #+digitool (subseq s 8) #+ecl (format nil "~A~@[-~A~]" s (let ((vcs-id (ext:lisp-implementation-vcs-id))) (when (>= (length vcs-id) 8) (subseq vcs-id 0 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")) ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version - #+(or cormanlisp mcl sbcl scl) s - #-(or allegro armedbear clisp clozure cmu cormanlisp digitool - ecl gcl lispworks mcl sbcl scl) s)) + #+mcl (subseq s 8) ; strip the leading "Version " + #+(or cormanlisp sbcl scl) s + #-(or allegro armedbear clisp clozure cmu cormanlisp + ecl gcl genera lispworks mcl sbcl scl) s)) (defun* first-feature (features) (labels @@ -2586,31 +2692,31 @@ *implementation-features*)) (os (maybe-warn (first-feature *os-features*) "No os feature found in ~a." *os-features*)) - (arch (maybe-warn (first-feature *architecture-features*) - "No architecture feature found in ~a." - *architecture-features*)) + (arch (or #-clisp + (maybe-warn (first-feature *architecture-features*) + "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~^-~}~)" lisp version os arch))))) - + #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\"")) + (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch))))) ;;; --------------------------------------------------------------------------- ;;; Generic support for configuration files (defparameter *inter-directory-separator* - #+(or unix cygwin) #\: - #-(or unix cygwin) #\;) + #+asdf-unix #\: + #-asdf-unix #\;) (defun* user-homedir () - (truename (user-homedir-pathname))) + (truenamize (pathname-directory-pathname (user-homedir-pathname)))) (defun* try-directory-subpath (x sub &key type) (let* ((p (and x (ensure-directory-pathname x))) (tp (and p (probe-file* p))) - (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p))) + (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p))) (ts (and sp (probe-file* sp)))) (and ts (values sp ts)))) (defun* user-configuration-directories () @@ -2621,7 +2727,7 @@ ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") :for dir :in (split-string dirs :separator ":") :collect (try dir "common-lisp/")) - #+(and (or win32 windows mswindows mingw32) (not cygwin)) + #+asdf-windows ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData ,(try (getenv "APPDATA") "common-lisp/config/")) @@ -2630,11 +2736,12 @@ (remove-if #'null (append - #+(and (or win32 windows mswindows mingw32) (not cygwin)) + #+asdf-windows (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) + #+asdf-unix (list #p"/etc/common-lisp/")))) (defun* in-first-directory (dirs x) (loop :for dir :in dirs @@ -2649,40 +2756,88 @@ (or (member x kw) (and (length=n-p x 1) (member (car x) kw))))) +(defun* report-invalid-form (reporter &rest args) + (etypecase reporter + (null + (apply 'error 'invalid-configuration args)) + (function + (apply reporter args)) + ((or symbol string) + (apply 'error reporter args)) + (cons + (apply 'apply (append reporter args))))) + +(defvar *ignored-configuration-form* nil) + (defun* validate-configuration-form (form tag directive-validator - &optional (description tag)) + &key location invalid-form-reporter) (unless (and (consp form) (eq (car form) tag)) - (error "Error: Form doesn't specify ~A ~S~%" description form)) - (loop :with inherit = 0 - :for directive :in (cdr form) :do - (if (configuration-inheritance-directive-p directive) - (incf inherit) - (funcall directive-validator directive)) + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form form :location location) + (return-from validate-configuration-form nil)) + (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) + :for directive :in (cdr form) + :when (cond + ((configuration-inheritance-directive-p directive) + (incf inherit) t) + ((eq directive :ignore-invalid-entries) + (setf ignore-invalid-p t) t) + ((funcall directive-validator directive) + t) + (ignore-invalid-p + nil) + (t + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form directive :location location) + nil)) + :do (push directive x) :finally (unless (= inherit 1) - (error "One and only one of ~S or ~S is required" - :inherit-configuration :ignore-inherited-configuration))) - form) + (report-invalid-form invalid-form-reporter + :arguments (list "One and only one of ~S or ~S is required" + :inherit-configuration :ignore-inherited-configuration))) + (return (nreverse x)))) -(defun* validate-configuration-file (file validator description) +(defun* validate-configuration-file (file validator &key description) (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) (error "One and only one form allowed for ~A. Got: ~S~%" description forms)) - (funcall validator (car forms)))) + (funcall validator (car forms) :location file))) (defun* hidden-file-p (pathname) (equal (first-char (pathname-name pathname)) #\.)) -(defun* validate-configuration-directory (directory tag validator) +(defun* directory* (pathname-spec &rest keys &key &allow-other-keys) + (apply 'directory pathname-spec + (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) + #+clozure '(:follow-links nil) + #+clisp '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil)))))) + +(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter) + "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will +be applied to the results to yield a configuration form. Current +values of TAG include :source-registry and :output-translations." (let ((files (sort (ignore-errors (remove-if 'hidden-file-p - (directory (make-pathname :name :wild :type "conf" :defaults directory) - #+sbcl :resolve-symlinks #+sbcl nil))) + (directory* (make-pathname :name :wild :type "conf" :defaults directory)))) #'string< :key #'namestring))) `(,tag ,@(loop :for file :in files :append - (mapcar validator (read-file-forms file))) + (loop :with ignore-invalid-p = nil + :for form :in (read-file-forms file) + :when (eq form :ignore-invalid-entries) + :do (setf ignore-invalid-p t) + :else + :when (funcall validator form) + :collect form + :else + :when ignore-invalid-p + :do (setf *ignored-configuration-form* t) + :else + :do (report-invalid-form invalid-form-reporter :form form :location file))) :inherit-configuration))) @@ -2703,7 +2858,7 @@ (flet ((try (x &rest sub) (and x `(,x ,@sub)))) (or (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) - #+(and (or win32 windows mswindows mingw32) (not cygwin)) + #+asdf-windows (try (getenv "APPDATA") "common-lisp" "cache" :implementation) '(:home ".cache" "common-lisp" :implementation)))) (defvar *system-cache* @@ -2718,11 +2873,12 @@ (setf *output-translations* (list (stable-sort (copy-list new-value) #'> - :key (lambda (x) - (etypecase (car x) - ((eql t) -1) - (pathname - (length (pathname-directory (car x))))))))) + :key #'(lambda (x) + (etypecase (car x) + ((eql t) -1) + (pathname + (let ((directory (pathname-directory (car x)))) + (if (listp directory) (length directory) 0)))))))) new-value) (defun* output-translations-initialized-p () @@ -2756,9 +2912,12 @@ (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))) - #-(and (or win32 windows mswindows mingw32) (not cygwin)) + #+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)))) @@ -2766,6 +2925,11 @@ (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames* s super))) +(defvar *here-directory* nil + "This special variable is bound to the currect directory during calls to +PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here +directive.") + (defun* resolve-absolute-location-component (x &key directory wilden) (let* ((r (etypecase x @@ -2788,6 +2952,11 @@ (let ((p (make-pathname :directory '(:relative)))) (if wilden (wilden p) p)))) ((eql :home) (user-homedir)) + ((eql :here) + (resolve-location (or *here-directory* + ;; give semantics in the case of use interactively + :default-directory) + :directory t :wilden nil)) ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) @@ -2812,8 +2981,17 @@ :finally (return path)))) (defun* location-designator-p (x) - (flet ((componentp (c) (typep c '(or string pathname keyword)))) - (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x))))) + (flet ((absolute-component-p (c) + (typep c '(or string pathname + (member :root :home :here :user-cache :system-cache :default-directory)))) + (relative-component-p (c) + (typep c '(or string pathname + (member :default-directory :*/ :**/ :*.*.* + :implementation :implementation-type + #+asdf-unix :uid))))) + (or (typep x 'boolean) + (absolute-component-p x) + (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) (defun* location-function-p (x) (and @@ -2826,47 +3004,43 @@ (length=n-p (second x) 2))))) (defun* validate-output-translations-directive (directive) - (unless - (or (member directive '(:inherit-configuration - :ignore-inherited-configuration - :enable-user-cache :disable-cache nil)) - (and (consp directive) - (or (and (length=n-p directive 2) - (or (and (eq (first directive) :include) - (typep (second directive) '(or string pathname null))) - (and (location-designator-p (first directive)) - (or (location-designator-p (second directive)) - (location-function-p (second directive)))))) - (and (length=n-p directive 1) - (location-designator-p (first directive)))))) - (error "Invalid directive ~S~%" directive)) - directive) + (or (member directive '(:enable-user-cache :disable-cache nil)) + (and (consp directive) + (or (and (length=n-p directive 2) + (or (and (eq (first directive) :include) + (typep (second directive) '(or string pathname null))) + (and (location-designator-p (first directive)) + (or (location-designator-p (second directive)) + (location-function-p (second directive)))))) + (and (length=n-p directive 1) + (location-designator-p (first directive))))))) -(defun* validate-output-translations-form (form) +(defun* validate-output-translations-form (form &key location) (validate-configuration-form form :output-translations 'validate-output-translations-directive - "output translations")) + :location location :invalid-form-reporter 'invalid-output-translation)) (defun* validate-output-translations-file (file) (validate-configuration-file - file 'validate-output-translations-form "output translations")) + file 'validate-output-translations-form :description "output translations")) (defun* validate-output-translations-directory (directory) (validate-configuration-directory - directory :output-translations 'validate-output-translations-directive)) + directory :output-translations 'validate-output-translations-directive + :invalid-form-reporter 'invalid-output-translation)) -(defun* parse-output-translations-string (string) +(defun* parse-output-translations-string (string &key location) (cond ((or (null string) (equal string "")) '(:output-translations :inherit-configuration)) ((not (stringp string)) (error "environment string isn't: ~S" string)) ((eql (char string 0) #\") - (parse-output-translations-string (read-from-string string))) + (parse-output-translations-string (read-from-string string) :location location)) ((eql (char string 0) #\() - (validate-output-translations-form (read-from-string string))) + (validate-output-translations-form (read-from-string string) :location location)) (t (loop :with inherit = nil @@ -2906,7 +3080,8 @@ `(:output-translations ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. - #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ()))) + #+sbcl ,(let ((h (getenv "SBCL_HOME"))) + (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ()))) #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system ;; All-import, here is where we want user stuff to be: @@ -2917,8 +3092,8 @@ ;; 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") -(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/") +(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) +(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) (defun* user-output-translations-pathname () (in-user-configuration-directory *output-translations-file* )) @@ -2946,7 +3121,7 @@ ((directory-pathname-p pathname) (process-output-translations (validate-output-translations-directory pathname) :inherit inherit :collect collect)) - ((probe-file pathname) + ((probe-file* pathname) (process-output-translations (validate-output-translations-file pathname) :inherit inherit :collect collect)) (t @@ -2974,7 +3149,7 @@ (process-output-translations-directive '(t t) :collect collect)) ((:inherit-configuration) (inherit-output-translations inherit :collect collect)) - ((:ignore-inherited-configuration nil) + ((:ignore-inherited-configuration :ignore-invalid-entries nil) nil)) (let ((src (first directive)) (dst (second directive))) @@ -2997,9 +3172,7 @@ (t (let* ((trudst (make-pathname :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) - (wilddst (make-pathname - :name :wild :type :wild :version :wild - :defaults trudst))) + (wilddst (merge-pathnames* *wild-file* trudst))) (funcall collect (list wilddst t)) (funcall collect (list trusrc trudst))))))))))) @@ -3011,10 +3184,13 @@ `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) :test 'equal :from-end t)) -(defun* initialize-output-translations (&optional parameter) +(defvar *output-translations-parameter* nil) + +(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*)) "read the configuration, initialize the internal configuration variable, return the configuration" - (setf (output-translations) (compute-output-translations parameter))) + (setf *output-translations-parameter* parameter + (output-translations) (compute-output-translations parameter))) (defun* disable-output-translations () "Initialize output translations in a way that maps every file to itself, @@ -3090,7 +3266,7 @@ :defaults x)) (defun* delete-file-if-exists (x) - (when (and x (probe-file x)) + (when (and x (probe-file* x)) (delete-file x))) (defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) @@ -3160,21 +3336,19 @@ (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))) - (mapped-files (make-pathname - :name :wild :version :wild - :type (if map-all-source-files :wild fasl-type))) + (mapped-files (if map-all-source-files *wild-file* + (make-pathname :name :wild :version :wild :type fasl-type))) (destination-directory (if centralize-lisp-binaries `(,default-toplevel-directory ,@(when include-per-user-information (cdr (pathname-directory (user-homedir)))) - :implementation ,wild-inferiors) - `(:root ,wild-inferiors :implementation)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) (initialize-output-translations `(:output-translations ,@source-to-target-mappings - ((:root ,wild-inferiors ,mapped-files) + ((:root ,*wild-inferiors* ,mapped-files) (,@destination-directory ,mapped-files)) (t t) :ignore-inherited-configuration)))) @@ -3185,7 +3359,7 @@ ;;;; Jesse Hager: The Windows Shortcut File Format. ;;;; http://www.wotsit.org/list.asp?fc=13 -#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) +#+(and asdf-windows (not clisp)) (progn (defparameter *link-initial-dword* 76) (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) @@ -3294,38 +3468,33 @@ (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)) + (ignore-errors + (and (directory* (merge-pathnames* *wild-asd* directory)) t))) (defun subdirectories (directory) (let* ((directory (ensure-directory-pathname directory)) - #-cormanlisp + #-(or cormanlisp genera) (wild (merge-pathnames* #-(or abcl allegro lispworks scl) - (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil) + *wild-directory* #+(or abcl allegro lispworks scl) "*.*" directory)) (dirs - #-cormanlisp + #-(or cormanlisp genera) (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) + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (fs:directory-list directory)) + #+(or abcl allegro genera 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))) + #+genera #'(lambda (x) (getf (cdr x) :directory)) + #-(or abcl allegro genera lispworks) #'directory-pathname-p + dirs)) + #+genera + (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs))) dirs)) (defun collect-sub*directories (directory collectp recursep collector) @@ -3346,39 +3515,40 @@ collect)) (defun* validate-source-registry-directive (directive) - (unless - (or (member directive '(:default-registry (:default-registry)) :test 'equal) - (destructuring-bind (kw &rest rest) directive - (case kw - ((:include :directory :tree) - (and (length=n-p rest 1) - (location-designator-p (first rest)))) - ((:exclude :also-exclude) - (every #'stringp rest)) - (null rest)))) - (error "Invalid directive ~S~%" directive)) - directive) + (or (member directive '(:default-registry)) + (and (consp directive) + (let ((rest (rest directive))) + (case (first directive) + ((:include :directory :tree) + (and (length=n-p rest 1) + (location-designator-p (first rest)))) + ((:exclude :also-exclude) + (every #'stringp rest)) + ((:default-registry) + (null rest))))))) -(defun* validate-source-registry-form (form) +(defun* validate-source-registry-form (form &key location) (validate-configuration-form - form :source-registry 'validate-source-registry-directive "a source registry")) + form :source-registry 'validate-source-registry-directive + :location location :invalid-form-reporter 'invalid-source-registry)) (defun* validate-source-registry-file (file) (validate-configuration-file - file 'validate-source-registry-form "a source registry")) + file 'validate-source-registry-form :description "a source registry")) (defun* validate-source-registry-directory (directory) (validate-configuration-directory - directory :source-registry 'validate-source-registry-directive)) + directory :source-registry 'validate-source-registry-directive + :invalid-form-reporter 'invalid-source-registry)) -(defun* parse-source-registry-string (string) +(defun* parse-source-registry-string (string &key location) (cond ((or (null string) (equal string "")) '(:source-registry :inherit-configuration)) ((not (stringp string)) (error "environment string isn't: ~S" string)) ((find (char string 0) "\"(") - (validate-source-registry-form (read-from-string string))) + (validate-source-registry-form (read-from-string string) :location location)) (t (loop :with inherit = nil @@ -3419,35 +3589,35 @@ system-source-registry-directory default-source-registry)) -(defparameter *source-registry-file* #p"source-registry.conf") -(defparameter *source-registry-directory* #p"source-registry.conf.d/") +(defparameter *source-registry-file* (coerce-pathname "source-registry.conf")) +(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/")) (defun* wrapping-source-registry () `(:source-registry - #+sbcl (:tree ,(getenv "SBCL_HOME")) + #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME"))) :inherit-configuration #+cmu (:tree #p"modules:"))) (defun* default-source-registry () (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) `(:source-registry #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir))) - (:directory ,(truenamize (directory-namestring *default-pathname-defaults*))) + (:directory ,(default-directory)) ,@(let* - #+(or unix cygwin) + #+asdf-unix ((datahome (or (getenv "XDG_DATA_HOME") (try (user-homedir) ".local/share/"))) (datadirs (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) (dirs (cons datahome (split-string datadirs :separator ":")))) - #+(and (or win32 windows mswindows mingw32) (not cygwin)) + #+asdf-windows ((datahome (getenv "APPDATA")) (datadir #+lispworks (sys:get-folder-path :local-appdata) #-lispworks (try (getenv "ALLUSERSPROFILE") "Application Data")) (dirs (list datahome datadir))) - #-(or unix win32 windows mswindows mingw32 cygwin) + #-(or asdf-unix asdf-windows) ((dirs ())) (loop :for dir :in dirs :collect `(:directory ,(try dir "common-lisp/systems/")) @@ -3475,11 +3645,13 @@ (defmethod process-source-registry ((pathname pathname) &key inherit register) (cond ((directory-pathname-p pathname) - (process-source-registry (validate-source-registry-directory pathname) - :inherit inherit :register register)) - ((probe-file pathname) - (process-source-registry (validate-source-registry-file pathname) - :inherit inherit :register register)) + (let ((*here-directory* (truenamize pathname))) + (process-source-registry (validate-source-registry-directory pathname) + :inherit inherit :register register))) + ((probe-file* pathname) + (let ((*here-directory* (pathname-directory-pathname pathname))) + (process-source-registry (validate-source-registry-file pathname) + :inherit inherit :register register))) (t (inherit-source-registry inherit :register register)))) (defmethod process-source-registry ((string string) &key inherit register) @@ -3527,13 +3699,14 @@ (defun* flatten-source-registry (&optional parameter) (remove-duplicates (while-collecting (collect) - (inherit-source-registry - `(wrapping-source-registry - ,parameter - ,@*default-source-registries*) - :register (lambda (directory &key recurse exclude) - (collect (list directory :recurse recurse :exclude exclude))))) - :test 'equal :from-end t)) + (let ((*default-pathname-defaults* (default-directory))) + (inherit-source-registry + `(wrapping-source-registry + ,parameter + ,@*default-source-registries*) + :register #'(lambda (directory &key recurse exclude) + (collect (list directory :recurse recurse :exclude exclude))))) + :test 'equal :from-end t))) ;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. @@ -3545,8 +3718,11 @@ directory :recurse recurse :exclude exclude :collect #'collect))))) -(defun* initialize-source-registry (&optional parameter) - (setf (source-registry) (compute-source-registry parameter))) +(defvar *source-registry-parameter* nil) + +(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) + (setf *source-registry-parameter* parameter + (source-registry) (compute-source-registry parameter))) ;; Checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in @@ -3579,9 +3755,9 @@ (handler-bind ((style-warning #'muffle-warning) (missing-component (constantly nil)) - (error (lambda (e) - (format *error-output* "ASDF could not load ~(~A~) because ~A.~%" - name e)))) + (error #'(lambda (e) + (errfmt *error-output* "ASDF could not load ~(~A~) because ~A.~%" + name e)))) (let* ((*verbose-out* (make-broadcast-stream)) (system (find-system (string-downcase name) nil))) (when system @@ -3605,17 +3781,11 @@ ;;;; Things to do in case we're upgrading from a previous version of ASDF. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; -;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1 -(eval-when (:compile-toplevel :load-toplevel :execute) - #+ecl ;; Support upgrade from before ECL went to 1.369 - (when (fboundp 'compile-op-system-p) - (defmethod compile-op-system-p ((op compile-op)) - (getf :system-p (compile-op-flags op))) - (defmethod initialize-instance :after ((op compile-op) - &rest initargs - &key system-p &allow-other-keys) - (declare (ignorable initargs)) - (when system-p (appendf (compile-op-flags op) (list :system-p system-p)))))) + +;;; If a previous version of ASDF failed to read some configuration, try again. +(when *ignored-configuration-form* + (clear-configuration) + (setf *ignored-configuration-form* nil)) ;;;; ----------------------------------------------------------------- ;;;; Done!

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www (download.html)
by Raymond Toy 07 Mar '11

07 Mar '11

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www/news (index.html)
by Raymond Toy 03 Mar '11

03 Mar '11

Date: Thursday, March 3, 2011 @ 12:07:44 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www/news Modified: index.html Add link to slime. ------------+ index.html | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) Index: cmucl-www/cmucl-www/www/news/index.html diff -u cmucl-www/cmucl-www/www/news/index.html:1.47 cmucl-www/cmucl-www/www/news/index.html:1.48 --- cmucl-www/cmucl-www/www/news/index.html:1.47 Thu Mar 3 12:04:07 2011 +++ cmucl-www/cmucl-www/www/news/index.html Thu Mar 3 12:07:44 2011 @@ -27,7 +27,9 @@ calls because <code>KERNEL:%SQRT</code> was not defined on x86 with SSE2. This is fixed now.</li> <li> In an earlier snapshot to add support for character name - completion with slime, a bug was introduced where cmucl could no + completion with <a + href="http://common-lisp.net/project/slime/">SLIME</a>, a bug was + introduced where cmucl could no longer read <code>#\latin_small_letter_a</code>. This is fixed in this version.<li> </ul>

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www (3 files)
by Raymond Toy 03 Mar '11

03 Mar '11

Date: Thursday, March 3, 2011 @ 12:04:07 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www Modified: download.html index.html news/index.html Update for snapshot 2011-03. -----------------+ download.html | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ index.html | 22 ++++++++++++++++++- news/index.html | 26 ++++++++++++++++++++-- 3 files changed, 106 insertions(+), 4 deletions(-) Index: cmucl-www/cmucl-www/www/download.html diff -u cmucl-www/cmucl-www/www/download.html:1.28 cmucl-www/cmucl-www/www/download.html:1.29 --- cmucl-www/cmucl-www/www/download.html:1.28 Fri Jan 21 09:48:37 2011 +++ cmucl-www/cmucl-www/www/download.html Thu Mar 3 12:04:06 2011 @@ -91,6 +91,68 @@ </tr> <tr> + <td>2011-03</td> + <td> +  + <ul> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Unicode</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Unicode extras</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Non-Unicode</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Non-Unicode extras</a></li> + </ul> + </td> + <td> + <ul> +  + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Unicode extras</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Non-Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Non-Unicode extras</a></li> + </ul> + </td> + <td> + + + </td> + <td> +  + <dl> + <dt>Solaris10/sparc + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Unicode</a></dd> + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Unicode extras</a></dd> + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Non-Unicode</a></dd> + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-2011…">Non-Unicode extras</a></> + + </td> + <td> + +  + </td> + <td> +  + <ul> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/cmucl-src-…">Source code</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2011/03/release-20…">Release notes for 20c</a></li> + </ul> + </td> + </tr> + + <tr> <td>2011-01</td> <td>  Index: cmucl-www/cmucl-www/www/index.html diff -u cmucl-www/cmucl-www/www/index.html:1.21 cmucl-www/cmucl-www/www/index.html:1.22 --- cmucl-www/cmucl-www/www/index.html:1.21 Thu Feb 3 11:11:15 2011 +++ cmucl-www/cmucl-www/www/index.html Thu Mar 3 12:04:06 2011 @@ -68,6 +68,26 @@ Also see <a href="news/index.html">News</a> for older news. <dl> +<dt>Snapshot 2011-03 +<dd> + The 2011-02 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 previous snapshot. + <ul> + <li> In <code>COMPILE-FILE</code>, the <code>:OUTPUT-FILE</code> can + also be a stream. CMUCL was erroneously signaling an error..</li> + + <li> <code>(OPEN f :DIRECTION :IO :IF-DOES-NOT-EXIST NIL)</code> no + longer signals an error if the file <code>f</code> does not exist. + It returns <code>NIL</code> now.</li> + <li> In some situations the compiler could not constant fold <code>SQRT</code> + calls because <code>KERNEL:%SQRT</code> was not defined on x86 + with SSE2. This is fixed now.</li> + <li> In an earlier snapshot to add support for character name + completion with slime, a bug was introduced where cmucl could no + longer read <code>#\latin_small_letter_a</code>. This is fixed + in this version.<li> + </ul> <dt>Snapshot 2011-02 <dd> The 2011-02 snapshot has been released. See the release notes for @@ -80,7 +100,7 @@ tracing local flet/labels functions. This doesn't actually trace anything. An error is now signaled in this case. If you are sure, you can specify <code>:ENCAPSULATE NIL</code> to disable - encapsulation. + encapsulation. </li> </ul> </dd> <dt>Snapshot 2011-01 Index: cmucl-www/cmucl-www/www/news/index.html diff -u cmucl-www/cmucl-www/www/news/index.html:1.46 cmucl-www/cmucl-www/www/news/index.html:1.47 --- cmucl-www/cmucl-www/www/news/index.html:1.46 Thu Feb 3 11:05:41 2011 +++ cmucl-www/cmucl-www/www/news/index.html Thu Mar 3 12:04:07 2011 @@ -11,7 +11,27 @@ <dl> -<dt>Snapshot 2011-02 +<dt>Snapshot 2011-03 +<dd> + The 2011-02 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 previous snapshot. + <ul> + <li> In <code>COMPILE-FILE</code>, the <code>:OUTPUT-FILE</code> can + also be a stream. CMUCL was erroneously signaling an error..</li> + + <li> <code>(OPEN f :DIRECTION :IO :IF-DOES-NOT-EXIST NIL)</code> no + longer signals an error if the file <code>f</code> does not exist. + It returns <code>NIL</code> now.</li> + <li> In some situations the compiler could not constant fold <code>SQRT</code> + calls because <code>KERNEL:%SQRT</code> was not defined on x86 + with SSE2. This is fixed now.</li> + <li> In an earlier snapshot to add support for character name + completion with slime, a bug was introduced where cmucl could no + longer read <code>#\latin_small_letter_a</code>. This is fixed + in this version.<li> + </ul> +<dt>Snapshot 2011-02 <dd> The 2011-02 snapshot has been released. See the release notes for details, but here is a quick summary of the changes between the @@ -26,7 +46,7 @@ encapsulation. </ul> </dd> -<dt>Snapshot 2011-01 +<dt>Snapshot 2011-01 <dd> The 2011-01 snapshot has been released. See the release notes for details, but here is a quick summary of the changes between the @@ -59,7 +79,7 @@ </ul> </dd> -<dt>2010-12 snapshot +<dt>Snapshot 2010-12 <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

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 03 Mar '11

03 Mar '11

Date: Thursday, March 3, 2011 @ 11:43:51 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Fix Trac #43: unread-char doesn't change file-position -----------------+ 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.19 src/general-info/release-20c.txt:1.20 --- src/general-info/release-20c.txt:1.19 Mon Feb 28 23:40:13 2011 +++ src/general-info/release-20c.txt Thu Mar 3 11:43:51 2011 @@ -122,6 +122,8 @@ Fix this. * Trac Tickets: + - #43: unread-char doesn't change file-position + Fixed. * Other changes:

1 0

[cmucl-cvs] CMUCL commit: src/code (stream.lisp)
by Raymond Toy 03 Mar '11

03 Mar '11

Date: Thursday, March 3, 2011 @ 11:43:29 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: stream.lisp Fix Trac #43: unread-char doesn't change file-position The issue is caused by FAST-READ-CHAR-STRING-REFILL. In some situations the number of octets converted is not exactly the same as the length of the buffer because the last octets in the buffer don't hold a complete encoded character. This is ok, but we didn't update the ibuf-head pointer to indicate that some octets haven't actually been converted. This confuses FILE-POSITION. -------------+ stream.lisp | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) Index: src/code/stream.lisp diff -u src/code/stream.lisp:1.99 src/code/stream.lisp:1.100 --- src/code/stream.lisp:1.99 Tue Sep 7 23:04:54 2010 +++ src/code/stream.lisp Thu Mar 3 11:43:28 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/stream.lisp,v 1.99 2010-09-08 03:04:54 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/stream.lisp,v 1.100 2011-03-03 16:43:28 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -723,6 +723,13 @@ (setf (lisp-stream-in-index stream) (1+ start)) (code-char (aref ibuf start)))))) +;;; FAST-READ-CHAR-STRING-REFILL -- Interface +;;; +;;; This function is called by the fast-read-char expansion to refill the +;;; string-buffer for text streams. There is definitely a +;;; string-buffer and an in-buffer, which implies there must be an +;;; n-bin method. +;;; #+unicode (defun fast-read-char-string-refill (stream eof-errorp eof-value) ;; Like fast-read-char-refill, but we don't need or want the @@ -844,6 +851,11 @@ (setf (lisp-stream-string-buffer-len stream) (1+ char-count)) (setf (lisp-stream-string-index stream) 2) (setf (lisp-stream-in-index stream) octet-count) + ;; If we didn't convert all the octets, + ;; adjust the head pointer to indicate + ;; that we have unread octets left. + (decf (lisp::fd-stream-ibuf-head stream) + (- (fd-stream-in-length stream) octet-count)) #+(or debug-frc-sr) (progn (format t "new in-index = ~A~%" (lisp-stream-in-index stream))

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 01 Mar '11

01 Mar '11

Date: Monday, February 28, 2011 @ 23:40:13 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Update from logs. Also, Solaris/x86 supports both sse2 and x87 now. -----------------+ release-20c.txt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.18 src/general-info/release-20c.txt:1.19 --- src/general-info/release-20c.txt:1.18 Wed Feb 16 21:55:45 2011 +++ src/general-info/release-20c.txt Mon Feb 28 23:40:13 2011 @@ -25,8 +25,7 @@ - Add support for character name completion. This can be used by Slime to do character name completion. - Initial support for Solaris/x86. CMUCL will run on Solaris/x86 - with all features available, except only Unicode and SSE2 is - supported. + with all features available, except only Unicode is supported. * Changes - ASDF2 updated to version 2.010. @@ -118,6 +117,9 @@ implementation packages. If you know what you're doing, you can use the trace option :encapsulate nil to trace them. Tracing functions used by TRACE can cause bad things. + - In some situations the compiler could not constant fold SQRT + calls because KERNEL:%SQRT was not defined on x86 with SSE2. + Fix this. * Trac Tickets:

1 0