X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=ce7a1db5a4b9e5be49312a4d39e2d15f06dd8ff2;hb=315285fcf8bf1f7e732da307cfaf31f18f412811;hp=d71b60bc7ddaa070bdc51a565c92ac3f6a73f74e;hpb=5385e8af2751efb74c274dcf649289e0082e745c;p=sbcl.git diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index d71b60b..ce7a1db 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ -;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.015.3: Another System Definition Facility. +;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- +;;; This is ASDF 2.26: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -19,7 +19,7 @@ ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; -;;; Copyright (c) 2001-2011 Daniel Barlow and contributors +;;; Copyright (c) 2001-2012 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -47,23 +47,33 @@ #+xcvb (module ()) -(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user) +(cl:in-package :common-lisp-user) +#+genera (in-package :future-common-lisp-user) -#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) -(error "ASDF is not supported on your implementation. Please help us with it.") +#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) +(error "ASDF is not supported on your implementation. Please help us port it.") + +;;;; Create and setup packages in a way that is compatible with hot-upgrade. +;;;; See https://bugs.launchpad.net/asdf/+bug/485687 +;;;; See these two eval-when forms, and more near the end of the file. #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this -(eval-when (:compile-toplevel :load-toplevel :execute) - ;;; Implementation-dependent tweaks - ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. +(eval-when (:load-toplevel :compile-toplevel :execute) + ;;; Before we do anything, some implementation-dependent tweaks + ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below - #+(and ecl (not ecl-bytecmp)) (require :cmp) - #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*) - #+(or unix cygwin) (pushnew :asdf-unix *features*) + #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 + (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all + (and (= system::*gcl-major-version* 2) + (< system::*gcl-minor-version* 7))) + (pushnew :gcl-pre2.7 *features*)) + #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) + clozure lispworks (and sbcl sb-unicode) scl) + (pushnew :asdf-unicode *features*) ;;; make package if it doesn't exist yet. ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. (unless (find-package :asdf) @@ -71,30 +81,34 @@ (in-package :asdf) -;;;; 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. - (eval-when (:load-toplevel :compile-toplevel :execute) + ;;; This would belong amongst implementation-dependent tweaks above, + ;;; except that the defun has to be in package asdf. + #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) + #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) + #+mkcl (require :cmp) + #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics + + ;;; Package setup, step 2. (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. + (defun find-symbol* (s p) + (find-symbol (string s) p)) ;; Strip out formatting that is not supported on Genera. ;; Has to be inside the eval-when to make Lispworks happy (!) + (defun strcat (&rest strings) + (apply 'concatenate 'string strings)) (defmacro compatfmt (format) - #-genera format - #+genera + #-(or gcl genera) format + #+(or gcl genera) (loop :for (unsupported . replacement) :in - '(("~@<" . "") - ("; ~@;" . "; ") - ("~3i~_" . "") - ("~@:>" . "") - ("~:>" . "")) :do + (append + '(("~3i~_" . "")) + #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do (loop :for found = (search unsupported format) :while found :do - (setf format - (concatenate 'simple-string - (subseq format 0 found) replacement - (subseq format (+ found (length unsupported))))))) + (setf format (strcat (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) format) (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 @@ -104,8 +118,8 @@ ;; "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.015.3") - (existing-asdf (fboundp 'find-system)) + (asdf-version "2.26") + (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) (unless (and existing-asdf already-there) @@ -115,7 +129,7 @@ existing-version asdf-version)) (labels ((present-symbol-p (symbol package) - (member (nth-value 1 (find-sym symbol package)) '(:internal :external))) + (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) @@ -145,12 +159,10 @@ p) (t (make-package name :nicknames nicknames :use use)))))) - (find-sym (symbol package) - (find-symbol (string symbol) package)) (intern* (symbol package) (intern (string symbol) package)) (remove-symbol (symbol package) - (let ((sym (find-sym symbol package))) + (let ((sym (find-symbol* symbol package))) (when sym #-cormanlisp (unexport sym package) (unintern sym package) @@ -161,19 +173,25 @@ :for removed = (remove-symbol sym package) :when removed :do (loop :for p :in packages :do - (when (eq removed (find-sym sym p)) + (when (eq removed (find-symbol* sym p)) (unintern removed p))))) (ensure-shadow (package symbols) (shadow symbols package)) (ensure-use (package use) + (dolist (used (package-use-list package)) + (unless (member (package-name used) use :test 'string=) + (unuse-package used) + (do-external-symbols (sym used) + (when (eq sym (find-symbol* sym package)) + (remove-symbol sym package))))) (dolist (used (reverse use)) (do-external-symbols (sym used) - (unless (eq sym (find-sym sym package)) + (unless (eq sym (find-symbol* sym package)) (remove-symbol sym package))) (use-package used package))) (ensure-fmakunbound (package symbols) (loop :for name :in symbols - :for sym = (find-sym name package) + :for sym = (find-symbol* name package) :when sym :do (fmakunbound sym))) (ensure-export (package export) (let ((formerly-exported-symbols nil) @@ -184,65 +202,60 @@ (push sym bothly-exported-symbols) (push sym formerly-exported-symbols))) (loop :for sym :in export :do - (unless (member sym bothly-exported-symbols :test 'string-equal) + (unless (member sym bothly-exported-symbols :test 'equal) (push sym newly-exported-symbols))) (loop :for user :in (package-used-by-list package) :for shadowing = (package-shadowing-symbols user) :do (loop :for new :in newly-exported-symbols - :for old = (find-sym new user) + :for old = (find-symbol* new user) :when (and old (not (member old shadowing))) :do (unintern old user))) (loop :for x :in newly-exported-symbols :do (export (intern* x package))))) - (ensure-package (name &key nicknames use unintern fmakunbound shadow export) + (ensure-package (name &key nicknames use unintern + shadow export redefined-functions) (let* ((p (ensure-exists name nicknames use))) - (ensure-unintern p unintern) + (ensure-unintern p (append unintern #+cmu redefined-functions)) (ensure-shadow p shadow) (ensure-export p export) - (ensure-fmakunbound p fmakunbound) + #-cmu (ensure-fmakunbound p redefined-functions) p))) (macrolet ((pkgdcl (name &key nicknames use export - redefined-functions unintern fmakunbound shadow) + redefined-functions unintern shadow) `(ensure-package ',name :nicknames ',nicknames :use ',use :export ',export :shadow ',shadow - :unintern ',(append #-(or gcl ecl) redefined-functions unintern) - :fmakunbound ',(append fmakunbound)))) + :unintern ',unintern + :redefined-functions ',redefined-functions))) (pkgdcl :asdf - :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only. :use (:common-lisp) :redefined-functions (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system #:apply-output-translations #:translate-pathname* #:resolve-location + #:system-relative-pathname + #:inherit-source-registry #:process-source-registry + #:process-source-registry-directive #:compile-file* #:source-file-type) :unintern (#:*asdf-revision* #:around #:asdf-method-combination - #:split #:make-collector + #:split #:make-collector #:do-dep #:do-one-dep + #:resolve-relative-location-component #:resolve-absolute-location-component #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function - :fmakunbound - (#:system-source-file - #:component-relative-pathname #:system-relative-pathname - #:process-source-registry - #:inherit-source-registry #:process-source-registry-directive) :export - (#:defsystem #:oos #:operate #:find-system #:run-shell-command + (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command #:system-definition-pathname #:with-system-definitions - #:search-for-system-definition #:find-component ; miscellaneous - #:compile-system #:load-system #:test-system #:clear-system - #:compile-op #:load-op #:load-source-op - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - #:version-satisfies + #:search-for-system-definition #:find-component #:component-find-path + #:compile-system #:load-system #:load-systems + #:require-system #:test-system #:clear-system + #:operation #:compile-op #:load-op #:load-source-op #:test-op + #:feature #:version #:version-satisfies #:upgrade-asdf - #:implementation-identifier #:implementation-type - - #:input-files #:output-files #:output-file #:perform ; operation methods + #:implementation-identifier #:implementation-type #:hostname + #:input-files #:output-files #:output-file #:perform #:operation-done-p #:explain #:component #:source-file @@ -258,7 +271,7 @@ #:unix-dso #:module-components ; component accessors - #:module-components-by-name ; component accessors + #:module-components-by-name #:component-pathname #:component-relative-pathname #:component-name @@ -266,8 +279,9 @@ #:component-parent #:component-property #:component-system - #:component-depends-on + #:component-encoding + #:component-external-format #:system-description #:system-long-description @@ -284,13 +298,15 @@ #:operation-on-warnings #:operation-on-failure #:component-visited-p - ;;#:*component-parent-pathname* - #:*system-definition-search-functions* - #:*central-registry* ; variables + + #:*system-definition-search-functions* ; variables + #:*central-registry* #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*resolve-symlinks* + #:*load-system-operation* #:*asdf-verbose* + #:*verbose-out* #:asdf-version @@ -313,6 +329,11 @@ #:coerce-entry-to-directory #:remove-entry-from-registry + #:*encoding-detection-hook* + #:*encoding-external-format-hook* + #:*default-encoding* + #:*utf-8-external-format* + #:clear-configuration #:*output-translations-parameter* #:initialize-output-translations @@ -330,34 +351,46 @@ #:clear-source-registry #:ensure-source-registry #:process-source-registry - #:system-registered-p + #:system-registered-p #:registered-systems #:loaded-systems + #:resolve-location #:asdf-message - - ;; Utilities - #:absolute-pathname-p + #:user-output-translations-pathname + #:system-output-translations-pathname + #:user-output-translations-directory-pathname + #:system-output-translations-directory-pathname + #:user-source-registry + #:system-source-registry + #:user-source-registry-directory + #:system-source-registry-directory + + ;; Utilities: please use asdf-utils instead + #| ;; #:aif #:it - ;; #:appendf + ;; #:appendf #:orf + #:length=n-p + #:remove-keys #:remove-keyword + #:first-char #:last-char #:string-suffix-p #:coerce-name - #:directory-pathname-p - ;; #:ends-with - #:ensure-directory-pathname - #:getenv - ;; #:get-uid - ;; #:length=n-p - ;; #:find-symbol* - #:merge-pathnames* - #:coerce-pathname - #:pathname-directory-pathname + #:directory-pathname-p #:ensure-directory-pathname + #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root + #:getenv #:getenv-pathname #:getenv-pathnames + #:getenv-absolute-directory #:getenv-absolute-directories + #:probe-file* + #:find-symbol* #:strcat + #:make-pathname-component-logical #:make-pathname-logical + #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname* + #:pathname-directory-pathname #:pathname-parent-directory-pathname #:read-file-forms - ;; #:remove-keys - ;; #:remove-keyword - #:resolve-symlinks + #:resolve-symlinks #:truenamize #:split-string #:component-name-to-pathname-components #:split-name-type - #:subdirectories - #:truenamize - #:while-collecting))) + #:subdirectories #:directory-files + #:while-collecting + #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* + #:*wild-path* #:wilden + #:directorize-pathname-host-device|# + ))) #+genera (import 'scl:boolean :asdf) (setf *asdf-version* asdf-version *upgraded-p* (if existing-version @@ -367,12 +400,6 @@ ;;;; ------------------------------------------------------------------------- ;;;; User-visible parameters ;;;; -(defun asdf-version () - "Exported interface to the version of ASDF currently installed. A string. -You can compare this string with e.g.: -(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." - *asdf-version*) - (defvar *resolve-symlinks* t "Determine whether or not ASDF resolves symlinks when defining systems. @@ -394,6 +421,16 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (defparameter +asdf-methods+ '(perform-with-restarts perform explain output-files operation-done-p)) +(defvar *load-system-operation* 'load-op + "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP. +You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle, +or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") + +(defvar *compile-op-compile-file-function* 'compile-file* + "Function used to compile lisp files.") + + + #+allegro (eval-when (:compile-toplevel :execute) (defparameter *acl-warn-save* @@ -415,27 +452,39 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when condition-arguments condition-form condition-format condition-location coerce-name) - #-cormanlisp + (ftype (function (&optional t) (values)) initialize-source-registry) + #-(or cormanlisp gcl-pre2.7) (ftype (function (t t) t) (setf module-components-by-name))) ;;;; ------------------------------------------------------------------------- -;;;; Compatibility with Corman Lisp +;;;; Compatibility various implementations #+cormanlisp (progn (deftype logical-pathname () nil) (defun make-broadcast-stream () *error-output*) + (defun translate-logical-pathname (x) x) (defun file-namestring (p) (setf p (pathname p)) - (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))) - (defparameter *count* 3) - (defun dbg (&rest x) - (format *error-output* "~S~%" x))) -#+cormanlisp -(defun maybe-break () - (decf *count*) - (unless (plusp *count*) - (setf *count* 3) - (break))) + (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) + +#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl + (read-from-string + "(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) + (ccl:define-entry-point (_system \"system\") ((name :string)) :int) + ;; Note: ASDF may expect user-homedir-pathname to provide + ;; the pathname of the current user's home directory, whereas + ;; MCL by default provides the directory from which MCL was started. + ;; See http://code.google.com/p/mcl/wiki/Portability + (defun current-user-homedir-pathname () + (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) + (defun probe-posix (posix-namestring) + \"If a file exists for the posix namestring, return the pathname\" + (ccl::with-cstrs ((cpath posix-namestring)) + (ccl::rlet ((is-dir :boolean) + (fsref :fsref)) + (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) + (ccl::%path-from-fsref fsref is-dir))))))")) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities @@ -444,7 +493,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when ((defdef (def* def) `(defmacro ,def* (name formals &rest rest) `(progn - #+(or ecl gcl) (fmakunbound ',name) + #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name) #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl `(declaim (notinline ,name))) @@ -471,6 +520,7 @@ Returns two values: \(A B C\) and \(1 2 3\)." (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) (defmacro aif (test then &optional else) + "Anaphoric version of IF, On Lisp style" `(let ((it ,test)) (if it ,then ,else))) (defun* pathname-directory-pathname (pathname) @@ -480,8 +530,9 @@ and NIL NAME, TYPE and VERSION components" (make-pathname :name nil :type nil :version nil :defaults pathname))) (defun* normalize-pathname-directory-component (directory) + "Given a pathname directory component, return an equivalent form that is a list" (cond - #-(or cmu sbcl scl) + #-(or cmu sbcl scl) ;; these implementations already normalize directory components. ((stringp directory) `(:absolute ,directory) directory) #+gcl ((and (consp directory) (stringp (first directory))) @@ -493,6 +544,7 @@ and NIL NAME, TYPE and VERSION components" (error (compatfmt "~@") directory)))) (defun* merge-pathname-directory-components (specified defaults) + ;; Helper for merge-pathnames* that handles directory components. (let ((directory (normalize-pathname-directory-component specified))) (ecase (first directory) ((nil) defaults) @@ -514,9 +566,30 @@ and NIL NAME, TYPE and VERSION components" :do (pop reldir) (pop defrev) :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) +(defun* make-pathname-component-logical (x) + "Make a pathname component suitable for use in a logical-pathname" + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + +(defun* make-pathname-logical (pathname host) + "Take a PATHNAME's directory, name, type and version components, +and make a new pathname with corresponding components and specified logical HOST" + (make-pathname + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname)))) + (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) - "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname -does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS. + "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that +if the SPECIFIED pathname does not have an absolute directory, +then the HOST and DEVICE both come from the DEFAULTS, whereas +if the SPECIFIED pathname does have an absolute directory, +then the HOST and DEVICE both come from the SPECIFIED. Also, if either argument is NIL, then the other argument is returned unmodified." (when (null specified) (return-from merge-pathnames* defaults)) (when (null defaults) (return-from merge-pathnames* specified)) @@ -529,10 +602,8 @@ Also, if either argument is NIL, then the other argument is returned unmodified. (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) - (labels ((ununspecific (x) - (if (eq x :unspecific) nil x)) - (unspecific-handler (p) - (if (typep p 'logical-pathname) #'ununspecific #'identity))) + (labels ((unspecific-handler (p) + (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) ((:absolute) @@ -555,10 +626,10 @@ Also, if either argument is NIL, then the other argument is returned unmodified. 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)) + :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. @@ -600,8 +671,9 @@ starting the separation from the end, e.g. when called with arguments (let ((unspecific ;; 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 clozure gcl lispworks sbcl) :unspecific))) + ;; We only use it on implementations that support it, + #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific + #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)) (destructuring-bind (name &optional (type unspecific)) (split-string filename :max 2 :separator ".") (if (equal name "") @@ -659,13 +731,9 @@ pathnames." :unless (eq k key) :append (list k v))) -#+mcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string)) - (defun* getenv (x) (declare (ignorable x)) - #+(or abcl clisp xcl) (ext:getenv x) + #+(or abcl clisp ecl xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) @@ -679,7 +747,6 @@ pathnames." (ct:c-string-to-lisp-string buffer1)) (ct:free buffer) (ct:free buffer1))) - #+ecl (si:getenv x) #+gcl (system:getenv x) #+genera nil #+lispworks (lispworks:environment-variable x) @@ -687,8 +754,9 @@ pathnames." (let ((value (_getenv name))) (unless (ccl:%null-ptr-p value) (ccl:%get-cstring value)))) + #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x) #+sbcl (sb-ext:posix-getenv x) - #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv)) (defun* directory-pathname-p (pathname) @@ -729,13 +797,63 @@ actually-existing directory." #+genera (unless (fboundp 'ensure-directories-exist) - (defun ensure-directories-exist (path) + (defun* ensure-directories-exist (path) (fs:create-directories-recursively (pathname path)))) (defun* absolute-pathname-p (pathspec) (and (typep pathspec '(or pathname string)) (eq :absolute (car (pathname-directory (pathname pathspec)))))) +(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. + ;; NOTE that the host and device slots will be taken from the defaults, + ;; 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) + (symbol + (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) + :force-relative t) + (multiple-value-bind (name type) + (cond + ((or (eq type :directory) (null filename)) + (values nil nil)) + (type + (values filename type)) + (t + (split-name-type filename))) + (apply 'make-pathname :directory (cons relative path) :name name :type type + (when defaults `(:defaults ,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.016. + (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") + (coerce-pathname name :type type :defaults defaults)) + +(defun* subpathname (pathname subpath &key type) + (and pathname (merge-pathnames* (coerce-pathname subpath :type type) + (pathname-directory-pathname pathname)))) + +(defun subpathname* (pathname subpath &key type) + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) + (defun* length=n-p (x n) ;is it that (= (length x) n) ? (check-type n (integer 0 *)) (loop @@ -745,7 +863,7 @@ actually-existing directory." ((zerop i) (return (null l))) ((not (consp l)) (return nil))))) -(defun* ends-with (s suffix) +(defun* string-suffix-p (s suffix) (check-type s string) (check-type suffix string) (let ((start (- (length s) (length suffix)))) @@ -759,39 +877,13 @@ actually-existing directory." :until (eq form eof) :collect form))) -#+asdf-unix -(progn - #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) - '(ffi:clines "#include " "#include ")) - (defun* get-uid () - #+allegro (excl.osi:getuid) - #+ccl (ccl::getuid) - #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") - :for f = (ignore-errors (read-from-string s)) - :when f :return (funcall f)) - #+(or cmu scl) (unix:unix-getuid) - #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601) - '(ffi:c-inline () () :int "getuid()" :one-liner t) - '(ext::getuid)) - #+sbcl (sb-unix:unix-getuid) - #-(or allegro ccl clisp cmu ecl sbcl scl) - (let ((uid-string - (with-output-to-string (*verbose-out*) - (run-shell-command "id -ur")))) - (with-input-from-string (stream uid-string) - (read-line stream) - (handler-case (parse-integer (read-line stream)) - (error () (error "Unable to find out user ID"))))))) - (defun* pathname-root (pathname) (make-pathname :directory '(:absolute) :name nil :type nil :version nil - :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) -(defun* find-symbol* (s p) - (find-symbol (string s) p)) - (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory with given pathname and if it exists return its truename." @@ -799,21 +891,25 @@ with given pathname and if it exists return its truename." (null nil) (string (probe-file* (parse-namestring p))) (pathname (unless (wild-pathname-p p) - #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p) - #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p))) + #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) + '(probe-file p) + #+clisp (aif (find-symbol* '#:probe-pathname :ext) + `(ignore-errors (,it p))) '(ignore-errors (truename p))))))) -(defun* truenamize (p) +(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) "Resolve as much of a pathname as possible" (block nil - (when (typep p '(or null logical-pathname)) (return p)) - (let* ((p (merge-pathnames* p)) - (directory (pathname-directory p))) + (when (typep pathname '(or null logical-pathname)) (return pathname)) + (let ((p (merge-pathnames* pathname defaults))) (when (typep p 'logical-pathname) (return p)) (let ((found (probe-file* p))) (when found (return found))) - #-(or cmu sbcl scl) (when (stringp directory) (return p)) - (when (not (eq :absolute (car directory))) (return p)) + (unless (absolute-pathname-p p) + (let ((true-defaults (ignore-errors (truename defaults)))) + (when true-defaults + (setf p (merge-pathnames pathname true-defaults))))) + (unless (absolute-pathname-p p) (return p)) (let ((sofar (probe-file* (pathname-root p)))) (unless sofar (return p)) (flet ((solution (directories) @@ -824,7 +920,9 @@ with given pathname and if it exists return its truename." :type (pathname-type p) :version (pathname-version p)) sofar))) - (loop :for component :in (cdr directory) + (loop :with directory = (normalize-pathname-directory-component + (pathname-directory p)) + :for component :in (cdr directory) :for rest :on (cdr directory) :for more = (probe-file* (merge-pathnames* @@ -847,7 +945,7 @@ with given pathname and if it exists return its truename." (and path (resolve-symlinks path)) path)) -(defun ensure-pathname-absolute (path) +(defun* ensure-pathname-absolute (path) (cond ((absolute-pathname-p path) path) ((stringp path) (ensure-pathname-absolute (pathname path))) @@ -864,7 +962,8 @@ with given pathname and if it exists return its truename." (defparameter *wild* #-cormanlisp :wild #+cormanlisp "*") (defparameter *wild-file* - (make-pathname :name *wild* :type *wild* :version *wild* :directory nil)) + (make-pathname :name *wild* :type *wild* + :version (or #-(or abcl xcl) *wild*) :directory nil)) (defparameter *wild-directory* (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil)) (defparameter *wild-inferiors* @@ -876,7 +975,7 @@ with given pathname and if it exists return its truename." (merge-pathnames* *wild-path* path)) #-scl -(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) +(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) @@ -906,24 +1005,22 @@ with given pathname and if it exists return its truename." (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))))) + (flet ((specificp (x) (and x (not (eq x :unspecific))))) + (if (or (specificp port) + (and (specificp host) (plusp (length host))) + (specificp scheme)) + (let ((prefix "")) + (when (specificp port) + (setf prefix (format nil ":~D" port))) + (when (and (specificp host) (plusp (length host))) + (setf prefix (strcat host prefix))) + (setf prefix (strcat ":" prefix)) + (when (specificp scheme) + (setf prefix (strcat scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + pathname))) ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. @@ -931,6 +1028,7 @@ with given pathname and if it exists return its truename." (defgeneric* perform-with-restarts (operation component)) (defgeneric* perform (operation component)) (defgeneric* operation-done-p (operation component)) +(defgeneric* mark-operation-done (operation component)) (defgeneric* explain (operation component)) (defgeneric* output-files (operation component)) (defgeneric* input-files (operation component)) @@ -960,7 +1058,11 @@ another pathname in a degenerate way.")) (defgeneric* (setf component-property) (new-value component property)) -(eval-when (:compile-toplevel :load-toplevel :execute) +(defgeneric* component-external-format (component)) + +(defgeneric* component-encoding (component)) + +(eval-when (#-gcl :compile-toplevel :load-toplevel :execute) (defgeneric* (setf module-components-by-name) (new-value module))) (defgeneric* version-satisfies (component version)) @@ -1037,22 +1139,22 @@ processed in order by OPERATE.")) ;;;; ------------------------------------------------------------------------- ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 (when *upgraded-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 *asdf-verbose* - (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) - (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*)))))))) + (when (find-class 'module nil) + (eval + '(defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when *asdf-verbose* + (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) + (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 @@ -1134,7 +1236,10 @@ processed in order by OPERATE.")) (defclass component () ((name :accessor component-name :initarg :name :type string :documentation "Component name: designator for a string composed of portable pathname characters") - (version :accessor component-version :initarg :version) ;; :type (and string (satisfies parse-version)) -- not until we fix all systems that don't use it correctly! + ;; We might want to constrain version with + ;; :type (and string (satisfies parse-version)) + ;; but we cannot until we fix all systems that don't use it correctly! + (version :accessor component-version :initarg :version) (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 @@ -1159,6 +1264,8 @@ processed in order by OPERATE.")) ;; 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! + ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. + ;; Maybe rename the slots in ASDF? But that's not very backwards compatible. ;; See our ASDF 2 paper for more complete explanations. (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) @@ -1172,9 +1279,12 @@ processed in order by OPERATE.")) ;; no direct accessor for pathname, we do this as a method to allow ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) + ;; the absolute-pathname is computed based on relative-pathname... (absolute-pathname) (operation-times :initform (make-hash-table) :accessor component-operation-times) + (around-compile :initarg :around-compile) + (%encoding :accessor %component-encoding :initform nil :initarg :encoding) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties @@ -1248,7 +1358,7 @@ processed in order by OPERATE.")) :initarg :if-component-dep-fails :accessor module-if-component-dep-fails) (default-component-class - :initform *default-component-class* + :initform nil :initarg :default-component-class :accessor module-default-component-class))) @@ -1266,8 +1376,8 @@ processed in order by OPERATE.")) (slot-value component 'absolute-pathname) (let ((pathname (merge-pathnames* - (component-relative-pathname component) - (pathname-directory-pathname (component-parent-pathname component))))) + (component-relative-pathname component) + (pathname-directory-pathname (component-parent-pathname component))))) (unless (or (null pathname) (absolute-pathname-p pathname)) (error (compatfmt "~@") pathname (component-find-path component))) @@ -1285,7 +1395,64 @@ processed in order by OPERATE.")) (acons property new-value (slot-value c 'properties))))) new-value) -(defclass system (module) +(defvar *default-encoding* :default + "Default encoding for source files. +The default value :default preserves the legacy behavior. +A future default might be :utf-8 or :autodetect +reading emacs-style -*- coding: utf-8 -*- specifications, +and falling back to utf-8 or latin1 if nothing is specified.") + +(defparameter *utf-8-external-format* + #+(and asdf-unicode (not clisp)) :utf-8 + #+(and asdf-unicode clisp) charset:utf-8 + #-asdf-unicode :default + "Default :external-format argument to pass to CL:OPEN and also +CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. +On modern implementations, this will decode UTF-8 code points as CL characters. +On legacy implementations, it may fall back on some 8-bit encoding, +with non-ASCII code points being read as several CL characters; +hopefully, if done consistently, that won't affect program behavior too much.") + +(defun* always-default-encoding (pathname) + (declare (ignore pathname)) + *default-encoding*) + +(defvar *encoding-detection-hook* #'always-default-encoding + "Hook for an extension to define a function to automatically detect a file's encoding") + +(defun* detect-encoding (pathname) + (funcall *encoding-detection-hook* pathname)) + +(defmethod component-encoding ((c component)) + (or (loop :for x = c :then (component-parent x) + :while x :thereis (%component-encoding x)) + (detect-encoding (component-pathname c)))) + +(defun* default-encoding-external-format (encoding) + (case encoding + (:default :default) ;; for backwards compatibility only. Explicit usage discouraged. + (:utf-8 *utf-8-external-format*) + (otherwise + (cerror "Continue using :external-format :default" (compatfmt "~@") encoding) + :default))) + +(defvar *encoding-external-format-hook* + #'default-encoding-external-format + "Hook for an extension to define a mapping between non-default encodings +and implementation-defined external-format's") + +(defun encoding-external-format (encoding) + (funcall *encoding-external-format-hook* encoding)) + +(defmethod component-external-format ((c component)) + (encoding-external-format (component-encoding c))) + +(defclass proto-system () ; slots to keep when resetting a system + ;; To preserve identity for all objects, we'd need keep the components slots + ;; but also to modify parse-component-form to reset the recycled objects. + ((name) #|(components) (components-by-names)|#)) + +(defclass system (module proto-system) (;; 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) @@ -1294,7 +1461,7 @@ processed in order by OPERATE.")) (maintainer :accessor system-maintainer :initarg :maintainer) (licence :accessor system-licence :initarg :licence :accessor system-license :initarg :license) - (source-file :reader system-source-file :initarg :source-file + (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade :writer %set-system-source-file) (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) @@ -1308,7 +1475,13 @@ processed in order by OPERATE.")) (return-from version-satisfies t)) (version-satisfies (component-version c) version)) -(defun parse-version (string &optional on-error) +(defun* asdf-version () + "Exported interface to the version of ASDF currently installed. A string. +You can compare this string with e.g.: +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." + *asdf-version*) + +(defun* parse-version (string &optional on-error) "Parse a version string as a series of natural integers separated by dots. Return a (non-null) list of integers if the string is valid, NIL otherwise. If on-error is error, warn, or designates a function of compatible signature, @@ -1340,6 +1513,80 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" (and x y (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) +;;;; ----------------------------------------------------------------- +;;;; Windows shortcut support. Based on: +;;;; +;;;; Jesse Hager: The Windows Shortcut File Format. +;;;; http://www.wotsit.org/list.asp?fc=13 + +#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. +(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)) + +(defun* read-null-terminated-string (s) + (with-output-to-string (out) + (loop :for code = (read-byte s) + :until (zerop code) + :do (write-char (code-char code) out)))) + +(defun* read-little-endian (s &optional (bytes 4)) + (loop :for i :from 0 :below bytes + :sum (ash (read-byte s) (* 8 i)))) + +(defun* parse-file-location-info (s) + (let ((start (file-position s)) + (total-length (read-little-endian s)) + (end-of-header (read-little-endian s)) + (fli-flags (read-little-endian s)) + (local-volume-offset (read-little-endian s)) + (local-offset (read-little-endian s)) + (network-volume-offset (read-little-endian s)) + (remaining-offset (read-little-endian s))) + (declare (ignore total-length end-of-header local-volume-offset)) + (unless (zerop fli-flags) + (cond + ((logbitp 0 fli-flags) + (file-position s (+ start local-offset))) + ((logbitp 1 fli-flags) + (file-position s (+ start + network-volume-offset + #x14)))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) + +(defun* parse-windows-shortcut (pathname) + (with-open-file (s pathname :element-type '(unsigned-byte 8)) + (handler-case + (when (and (= (read-little-endian s) *link-initial-dword*) + (let ((header (make-array (length *link-guid*)))) + (read-sequence header s) + (equalp header *link-guid*))) + (let ((flags (read-little-endian s))) + (file-position s 76) ;skip rest of header + (when (logbitp 0 flags) + ;; skip shell item id list + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (cond + ((logbitp 1 flags) + (parse-file-location-info s)) + (t + (when (logbitp 2 flags) + ;; skip description string + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (when (logbitp 3 flags) + ;; finally, our pathname + (let* ((length (read-little-endian s 2)) + (buffer (make-array length))) + (read-sequence buffer s) + (map 'string #'code-char buffer))))))) + (end-of-file () + nil))))) + ;;;; ------------------------------------------------------------------------- ;;;; Finding systems @@ -1363,6 +1610,10 @@ of which is a system object.") (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) +(defun* registered-systems () + (loop :for (() . system) :being :the :hash-values :of *defined-systems* + :collect (coerce-name system))) + (defun* register-system (system) (check-type system system) (let ((name (component-name system))) @@ -1395,15 +1646,25 @@ called with an object of type asdf:system." ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- -(defparameter *system-definition-search-functions* - '(sysdef-central-registry-search - sysdef-source-registry-search - sysdef-find-asdf)) +(defvar *system-definition-search-functions* '()) + +(setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. + (remove 'contrib-sysdef-search *system-definition-search-functions*) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; but then it will be the responsibility of whoever does that + ;; to upgrade asdf before he does such a thing rather than after. + (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-asdf)))) (defun* search-for-system-definition (system) - (let ((system-name (coerce-name system))) - (some #'(lambda (x) (funcall x system-name)) - (cons 'find-system-if-being-defined *system-definition-search-functions*)))) + (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) + (cons 'find-system-if-being-defined + *system-definition-search-functions*))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -1420,26 +1681,43 @@ This is for backward compatibilily. Going forward, we recommend new users should be using the source-registry. ") +(defun* featurep (x &optional (features *features*)) + (cond + ((atom x) + (and (member x features) t)) + ((eq :not (car x)) + (assert (null (cddr x))) + (not (featurep (cadr x) features))) + ((eq :or (car x)) + (some #'(lambda (x) (featurep x features)) (cdr x))) + ((eq :and (car x)) + (every #'(lambda (x) (featurep x features)) (cdr x))) + (t + (error "Malformed feature specification ~S" x)))) + +(defun* os-unix-p () + (featurep '(:or :unix :cygwin :darwin))) + +(defun* os-windows-p () + (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) + (defun* probe-asd (name defaults) (block nil (when (directory-pathname-p defaults) - (let ((file - (make-pathname - :defaults defaults :version :newest :case :local - :name name - :type "asd"))) - (when (probe-file* file) + (let* ((file (probe-file* (subpathname defaults (strcat name ".asd"))))) + (when file (return file))) - #+(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) - (let ((target (parse-windows-shortcut shortcut))) - (when target - (return (pathname target))))))))) + #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) + (when (os-windows-p) + (let ((shortcut + (make-pathname + :defaults defaults :version :newest :case :local + :name (strcat name ".asd") + :type "lnk"))) + (when (probe-file* shortcut) + (let ((target (parse-windows-shortcut shortcut))) + (when target + (return (pathname target)))))))))) (defun* sysdef-central-registry-search (system) (let ((name (coerce-name system)) @@ -1508,6 +1786,7 @@ Going forward, we recommend new users should be using the source-registry. 0))) (defmethod find-system ((name null) &optional (error-p t)) + (declare (ignorable name)) (when error-p (sysdef-error (compatfmt "~@")))) @@ -1527,7 +1806,7 @@ Going forward, we recommend new users should be using the source-registry. (let ((*systems-being-defined* (make-hash-table :test 'equal))) (funcall thunk)))) -(defmacro with-system-definitions (() &body body) +(defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () ,@body))) (defun* load-sysdef (name pathname) @@ -1540,23 +1819,39 @@ Going forward, we recommend new users should be using the source-registry. (error 'load-system-definition-error :name name :pathname pathname :condition condition)))) - (let ((*package* package)) + (let ((*package* package) + (*default-pathname-defaults* + ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. + (pathname-directory-pathname (translate-logical-pathname pathname))) + (external-format (encoding-external-format (detect-encoding pathname)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") pathname package) - (load pathname))) + (load pathname :external-format external-format))) (delete-package package))))) -(defmethod find-system ((name string) &optional (error-p t)) - (with-system-definitions () - (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) - (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))))) +(defun* locate-system (name) + "Given a system NAME designator, try to locate where to load the system from. +Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME +FOUNDP is true when a system was found, +either a new unregistered one or a previously registered one. +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is +PATHNAME when not null is a path from where to load the system, +either associated with FOUND-SYSTEM, or with the PREVIOUS system. +PREVIOUS when not null is a previously loaded SYSTEM object of same name. +PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous)))) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (when foundp (setf pathname (resolve-symlinks* pathname)) (when (and pathname (not (absolute-pathname-p pathname))) (setf pathname (ensure-pathname-absolute pathname)) @@ -1566,23 +1861,37 @@ Going forward, we recommend new users should be using the source-registry. (system-source-file previous) pathname))) (%set-system-source-file pathname previous) (setf previous-time nil)) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and pathname - (or (not previous-time) - ;; 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. - (< previous-time (safe-file-write-date pathname) (get-universal-time)))) - (load-sysdef name pathname)) - (let ((in-memory (system-registered-p name))) ; try again after loading from disk - (cond - (in-memory - (when pathname - (setf (car in-memory) (safe-file-write-date pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name))))))) + (values foundp found-system pathname previous previous-time)))) + +(defmethod find-system ((name string) &optional (error-p t)) + (with-system-definitions () + (loop + (restart-case + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (declare (ignore foundp)) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and pathname + (or (not previous-time) + ;; 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. + (< previous-time (safe-file-write-date pathname) (get-universal-time)))) + (load-sysdef name pathname)) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (return + (cond + (in-memory + (when pathname + (setf (car in-memory) (safe-file-write-date pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)))))) + (reinitialize-source-registry-and-retry () + :report (lambda (s) + (format s (compatfmt "~@") name)) + (initialize-source-registry)))))) (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) @@ -1655,49 +1964,6 @@ Going forward, we recommend new users should be using the source-registry. (declare (ignorable s)) (source-file-explicit-type component)) -(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. - ;; NOTE that the host and device slots will be taken from the defaults, - ;; 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) - (symbol - (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) - :force-relative t) - (multiple-value-bind (name type) - (cond - ((or (eq type :directory) (null filename)) - (values nil nil)) - (type - (values filename type)) - (t - (split-name-type filename))) - (apply 'make-pathname :directory (cons relative path) :name name :type type - ;; XCL 0.0.0.291 and ABCL 0.25 have a bug, whereby make-pathname merges directories like merge-pathnames when a :defaults is provided. Fixed in the latest XCL. - (when defaults `(:defaults ,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.016. - (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") - (coerce-pathname name :type type :defaults defaults)) - (defmethod component-relative-pathname ((component component)) (coerce-pathname (or (slot-value component 'relative-pathname) @@ -1720,6 +1986,7 @@ Host, device and version components are taken from DEFAULTS." ;; to force systems named in a given list ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 (forced :initform nil :initarg :force :accessor operation-forced) + (forced-not :initform nil :initarg :force-not :accessor operation-forced-not) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) @@ -1732,10 +1999,15 @@ Host, device and version components are taken from DEFAULTS." (prin1 (operation-original-initargs o) stream)))) (defmethod shared-initialize :after ((operation operation) slot-names - &key force + &key force force-not &allow-other-keys) - (declare (ignorable operation slot-names force)) - ;; empty method to disable initarg validity checking + ;; the &allow-other-keys disables initarg validity checking + (declare (ignorable operation slot-names force force-not)) + (macrolet ((frob (x) ;; normalize forced and forced-not slots + `(when (consp (,x operation)) + (setf (,x operation) + (mapcar #'coerce-name (,x operation)))))) + (frob operation-forced) (frob operation-forced-not)) (values)) (defun* node-for (o c) @@ -1807,10 +2079,9 @@ class specifier, not an operation." (cdr (assoc (type-of o) (component-in-order-to c)))) (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=)) - all-deps))) + (remove-if-not + #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) + (component-depends-on o c))) (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) @@ -1854,7 +2125,7 @@ class specifier, not an operation." ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE. (and op-time (>= op-time (latest-in)))) ((not in-files) - ;; an operation without output-files and no input-files + ;; an operation with output-files and no input-files ;; is probably meant for its side-effects on the file-system, ;; assumed to have to be done everytime. ;; (I don't think there is any such case in ASDF unless extended) @@ -1896,76 +2167,89 @@ recursive calls to traverse.") (defgeneric* do-traverse (operation component collect)) -(defun* %do-one-dep (operation c collect required-op required-c required-v) - ;; collects a partial plan that results from performing required-op - ;; on required-c, possibly with a required-vERSION - (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c))) - (and d (version-satisfies d required-v) d)) - (if required-v - (error 'missing-dependency-of-version - :required-by c - :version required-v - :requires required-c) - (error 'missing-dependency - :required-by c - :requires required-c)))) - (op (make-sub-operation c operation dep-c required-op))) - (do-traverse op dep-c collect))) - -(defun* do-one-dep (operation c collect required-op required-c required-v) - ;; this function is a thin, error-handling wrapper around %do-one-dep. - ;; Collects a partial plan per that function. +(defun* resolve-dependency-name (component name &optional version) (loop (restart-case - (return (%do-one-dep operation c collect - required-op required-c required-v)) + (return + (let ((comp (find-component (component-parent component) name))) + (unless comp + (error 'missing-dependency + :required-by component + :requires name)) + (when version + (unless (version-satisfies comp version) + (error 'missing-dependency-of-version + :required-by component + :version version + :requires name))) + comp)) (retry () :report (lambda (s) - (format s "~@" required-c)) + (format s (compatfmt "~@") name)) :test (lambda (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: - ;; op seems to at least potentially be a symbol, rather than an operation - ;; dep is a list of component names - (cond ((eq op 'feature) - (if (member (car dep) *features*) + (eq (missing-required-by c) component) + (equal (missing-requires c) name)))))))) + +(defun* resolve-dependency-spec (component dep-spec) + (cond + ((atom dep-spec) + (resolve-dependency-name component dep-spec)) + ;; Structured dependencies --- this parses keywords. + ;; The keywords could conceivably be broken out and cleanly (extensibly) + ;; processed by EQL methods. But for now, here's what we've got. + ((eq :version (first dep-spec)) + ;; https://bugs.launchpad.net/asdf/+bug/527788 + (resolve-dependency-name component (second dep-spec) (third dep-spec))) + ((eq :feature (first dep-spec)) + ;; This particular subform is not documented and + ;; has always been broken in the past. + ;; Therefore no one uses it, and I'm cerroring it out, + ;; after fixing it + ;; See https://bugs.launchpad.net/asdf/+bug/518467 + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") + (when (find (second dep-spec) *features* :test 'string-equal) + (resolve-dependency-name component (third dep-spec)))) + (t + (error (compatfmt "~@ ), (:feature ), or .~@:>") dep-spec)))) + +(defun* do-one-dep (op c collect dep-op dep-c) + ;; Collects a partial plan for performing dep-op on dep-c + ;; as dependencies of a larger plan involving op and c. + ;; Returns t if this should force recompilation of those who depend on us. + ;; dep-op is an operation class name (not an operation object), + ;; whereas dep-c is a component object.n + (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect)) + +(defun* do-dep (op c collect dep-op-spec dep-c-specs) + ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs + ;; as dependencies of a larger plan involving op and c. + ;; Returns t if this should force recompilation of those who depend on us. + ;; dep-op-spec is either an operation class name (not an operation object), + ;; or the magic symbol asdf:feature. + ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword, + ;; and the plan will succeed if that keyword is present in *feature*, + ;; or fail if it isn't + ;; (at which point c's :if-component-dep-fails will kick in). + ;; If dep-op-spec is an operation class name, + ;; then dep-c-specs specifies a list of sibling component of c, + ;; as per resolve-dependency-spec, such that operating op on c + ;; depends on operating dep-op-spec on each of them. + (cond ((eq dep-op-spec 'feature) + (if (member (car dep-c-specs) *features*) nil (error 'missing-dependency :required-by c - :requires (car dep)))) + :requires (list :feature (car dep-c-specs))))) (t (let ((flag nil)) - (flet ((dep (op comp ver) - (when (do-one-dep operation c collect - op comp ver) - (setf flag t)))) - (dolist (d dep) - (if (atom d) - (dep op d nil) - ;; structured dependencies --- this parses keywords - ;; the keywords could be broken out and cleanly (extensibly) - ;; processed by EQL methods - (cond ((eq :version (first d)) - ;; https://bugs.launchpad.net/asdf/+bug/527788 - (dep op (second d) (third d))) - ;; This particular subform is not documented and - ;; has always been broken in the past. - ;; Therefore no one uses it, and I'm cerroring it out, - ;; after fixing it - ;; See https://bugs.launchpad.net/asdf/+bug/518467 - ((eq :feature (first d)) - (cerror "Continue nonetheless." - "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") - (when (find (second d) *features* :test 'string-equal) - (dep op (third d) nil))) - (t - (error (compatfmt "~@), (:feature [version]), or a name.~@:>") d)))))) + (dolist (d dep-c-specs) + (when (do-one-dep op c collect dep-op-spec + (resolve-dependency-spec c d)) + (setf flag t))) flag)))) (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes @@ -1991,14 +2275,17 @@ recursive calls to traverse.") (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) (unwind-protect - (progn - (let ((f (operation-forced - (operation-ancestor operation)))) - (when (and f (or (not (consp f)) ;; T or :ALL - (and (typep c 'system) ;; list of names of systems to force - (member (component-name c) f - :test #'string=)))) - (setf *forcing* t))) + (block nil + (when (typep c 'system) ;; systems can be forced or forced-not + (let ((ancestor (operation-ancestor operation))) + (flet ((match? (f) + (and f (or (not (consp f)) ;; T or :ALL + (member (component-name c) f :test #'equal))))) + (cond + ((match? (operation-forced ancestor)) + (setf *forcing* t)) + ((match? (operation-forced-not ancestor)) + (return)))))) ;; first we check and do all the dependencies for the module. ;; Operations planned in this loop will show up ;; in the results, and are consumed below. @@ -2026,6 +2313,7 @@ recursive calls to traverse.") (handler-case (update-flag (do-traverse operation kid #'internal-collect)) + #-genera (missing-dependency (condition) (when (eq (module-if-component-dep-fails c) :fail) @@ -2052,9 +2340,9 @@ recursive calls to traverse.") :do (do-dep operation c collect required-op deps))) (do-collect collect (vector module-ops)) (do-collect collect (cons operation c))))) - (setf (visiting-component operation c) nil))) - (visit-component operation c (when flag (incf *visit-count*))) - flag)) + (setf (visiting-component operation c) nil))) + (visit-component operation c (when flag (incf *visit-count*))) + flag)) (defun* flatten-tree (l) ;; You collected things into a list. @@ -2073,9 +2361,6 @@ recursive calls to traverse.") (r* l)))) (defmethod traverse ((operation operation) (c component)) - (when (consp (operation-forced operation)) - (setf (operation-forced operation) - (mapcar #'coerce-name (operation-forced operation)))) (flatten-tree (while-collecting (collect) (let ((*visit-count* 0)) @@ -2090,6 +2375,35 @@ recursive calls to traverse.") (declare (ignorable operation c)) nil) +(defmethod mark-operation-done ((operation operation) (c component)) + (setf (gethash (type-of operation) (component-operation-times c)) + (reduce #'max + (cons (get-universal-time) + (mapcar #'safe-file-write-date (input-files operation c)))))) + +(defmethod perform-with-restarts (operation component) + ;; TOO verbose, especially as the default. Add your own :before method + ;; to perform-with-restart or perform if you want that: + #|(when *asdf-verbose* (explain operation component))|# + (perform operation component)) + +(defmethod perform-with-restarts :around (operation component) + (loop + (restart-case + (return (call-next-method)) + (retry () + :report + (lambda (s) + (format s (compatfmt "~@") + (operation-description operation component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@") + (operation-description operation component))) + (mark-operation-done operation component) + (return))))) + (defmethod explain ((operation operation) (component component)) (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description operation component))) @@ -2110,30 +2424,49 @@ recursive calls to traverse.") (flags :initarg :flags :accessor compile-op-flags :initform nil))) -(defun output-file (operation component) +(defun* output-file (operation component) "The unique output file of performing OPERATION on COMPONENT" (let ((files (output-files operation component))) (assert (length=n-p files 1)) (first files))) +(defun* ensure-all-directories-exist (pathnames) + (dolist (pathname pathnames) + (ensure-directories-exist (translate-logical-pathname pathname)))) + (defmethod perform :before ((operation compile-op) (c source-file)) - (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))) + (ensure-all-directories-exist (output-files operation c))) (defmethod perform :after ((operation operation) (c component)) - (setf (gethash (type-of operation) (component-operation-times c)) - (get-universal-time))) + (mark-operation-done operation c)) -(defvar *compile-op-compile-file-function* 'compile-file* - "Function used to compile lisp files.") +(defgeneric* around-compile-hook (component)) +(defgeneric* call-with-around-compile-hook (component thunk)) + +(defmethod around-compile-hook ((c component)) + (cond + ((slot-boundp c 'around-compile) + (slot-value c 'around-compile)) + ((component-parent c) + (around-compile-hook (component-parent c))))) + +(defun ensure-function (fun &key (package :asdf)) + (etypecase fun + ((or symbol function) fun) + (cons (eval `(function ,fun))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + +(defmethod call-with-around-compile-hook ((c component) thunk) + (let ((hook (around-compile-hook c))) + (if hook + (funcall (ensure-function hook) thunk) + (funcall thunk)))) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy (defmethod perform ((operation compile-op) (c cl-source-file)) - #-:broken-fasl-loader (let ((source-file (component-pathname c)) ;; on some implementations, there are more than one output-file, ;; but the first one should always be the primary fasl that gets loaded. @@ -2141,15 +2474,14 @@ recursive calls to traverse.") (*compile-file-warnings-behaviour* (operation-on-warnings operation)) (*compile-file-failure-behaviour* (operation-on-failure operation))) (multiple-value-bind (output warnings-p failure-p) - (apply *compile-op-compile-file-function* source-file :output-file output-file - (compile-op-flags operation)) - (when warnings-p - (case (operation-on-warnings operation) - (:warn (warn - (compatfmt "~@") - operation c)) - (:error (error 'compile-warned :component c :operation operation)) - (:ignore nil))) + (call-with-around-compile-hook + c #'(lambda (&rest flags) + (apply *compile-op-compile-file-function* source-file + :output-file output-file + :external-format (component-external-format c) + (append flags (compile-op-flags operation))))) + (unless output + (error 'compile-error :component c :operation operation)) (when failure-p (case (operation-on-failure operation) (:warn (warn @@ -2157,14 +2489,25 @@ recursive calls to traverse.") operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) - (unless output - (error 'compile-error :component c :operation operation))))) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn + (compatfmt "~@") + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil)))))) (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)) - #+broken-fasl-loader (list p))) + (let* ((p (lispize-pathname (component-pathname c))) + (f (compile-file-pathname ;; fasl + p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)) + #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file + #+ecl (if (use-ecl-byte-compiler-p) + (list f) + (list (compile-file-pathname p :type :object) f)) + #+mkcl (list o f) + #-(or ecl mkcl) (list f))) (defmethod perform ((operation compile-op) (c static-file)) (declare (ignorable operation c)) @@ -2194,53 +2537,24 @@ recursive calls to traverse.") (defclass load-op (basic-load-op) ()) -(defmethod perform ((o load-op) (c cl-source-file)) - (map () #'load (input-files o c))) - -(defmethod perform-with-restarts (operation component) - ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default. - (perform operation component)) - (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) - (declare (ignorable o)) - (loop :with state = :initial - :until (or (eq state :success) - (eq state :failure)) :do - (case state - (:recompiled - (setf state :failure) - (call-next-method) - (setf state :success)) - (:failed-load - (setf state :recompiled) - (perform (make-sub-operation c o c 'compile-op) c)) - (t - (with-simple-restart - (try-recompiling "Recompile ~a and try loading it again" - (component-name c)) - (setf state :failed-load) - (call-next-method) - (setf state :success)))))) - -(defmethod perform-with-restarts ((o compile-op) (c cl-source-file)) - (loop :with state = :initial - :until (or (eq state :success) - (eq state :failure)) :do - (case state - (:recompiled - (setf state :failure) - (call-next-method) - (setf state :success)) - (:failed-compile - (setf state :recompiled) - (perform-with-restarts o c)) - (t - (with-simple-restart - (try-recompiling "Try recompiling ~a" - (component-name c)) - (setf state :failed-compile) - (call-next-method) - (setf state :success)))))) + (loop + (restart-case + (return (call-next-method)) + (try-recompiling () + :report (lambda (s) + (format s "Recompile ~a and try loading it again" + (component-name c))) + (perform (make-sub-operation c o c 'compile-op) c))))) + +(defmethod perform ((o load-op) (c cl-source-file)) + (map () #'load + #-(or ecl mkcl) + (input-files o c) + #+(or ecl mkcl) + (loop :for i :in (input-files o c) + :unless (string= (pathname-type i) "fas") + :collect (compile-file-pathname (lispize-pathname i))))) (defmethod perform ((operation load-op) (c static-file)) (declare (ignorable operation c)) @@ -2283,7 +2597,8 @@ recursive calls to traverse.") (declare (ignorable o)) (let ((source (component-pathname c))) (setf (component-property c 'last-loaded-as-source) - (and (load source) + (and (call-with-around-compile-hook + c #'(lambda () (load source :external-format (component-external-format c)))) (get-universal-time))))) (defmethod perform ((operation load-source-op) (c static-file)) @@ -2294,7 +2609,7 @@ recursive calls to traverse.") (declare (ignorable operation c)) nil) -;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. +;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right. (defmethod component-depends-on ((o load-source-op) (c component)) (declare (ignorable o)) (loop :with what-would-load-op-do = (component-depends-on 'load-op c) @@ -2343,56 +2658,45 @@ recursive calls to traverse.") (defgeneric* operate (operation-class system &key &allow-other-keys)) (defgeneric* perform-plan (plan &key)) +;;;; Separating this into a different function makes it more forward-compatible +(defun* cleanup-upgraded-asdf (old-version) + (let ((new-version (asdf-version))) + (unless (equal old-version new-version) + (cond + ((version-satisfies new-version old-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + ((version-satisfies old-version new-version) + (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + (t + (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") + old-version new-version))) + (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) + ;; Invalidate all systems but ASDF itself. + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + ;; If we're in the middle of something, restart it. + (when *systems-being-defined* + (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) + (clrhash *systems-being-defined*) + (dolist (s l) (find-system s nil)))) + t)))) + ;;;; Try to upgrade of ASDF. If a different version was used, return T. ;;;; We need do that before we operate on anything that depends on ASDF. (defun* upgrade-asdf () - (let ((version (asdf:asdf-version))) + (let ((version (asdf-version))) (handler-bind (((or style-warning warning) #'muffle-warning)) (operate 'load-op :asdf :verbose nil)) - (let ((new-version (asdf:asdf-version))) - (block nil - (cond - ((equal version new-version) - (return nil)) - ((version-satisfies new-version version) - (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") - version new-version)) - ((version-satisfies version new-version) - (warn (compatfmt "~&~@~%") - version new-version)) - (t - (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") - version new-version))) - (let ((asdf (find-system :asdf))) - ;; invalidate all systems but ASDF itself - (setf *defined-systems* (make-defined-systems-table)) - (register-system asdf) - t))))) + (cleanup-upgraded-asdf version))) (defmethod perform-plan ((steps list) &key) (let ((*package* *package*) (*readtable* *readtable*)) (with-compilation-unit () (loop :for (op . component) :in steps :do - (loop - (restart-case - (progn - (perform-with-restarts op component) - (return)) - (retry () - :report - (lambda (s) - (format s (compatfmt "~@") - (operation-description op component)))) - (accept () - :report - (lambda (s) - (format s (compatfmt "~@") - (operation-description op component))) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))))) + (perform-with-restarts op component))))) (defmethod operate (operation-class system &rest args &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force @@ -2410,9 +2714,8 @@ recursive calls to traverse.") (error 'missing-component-of-version :requires system :version version)) (let ((steps (traverse op system))) (when (and (not (equal '("asdf") (component-find-path system))) - (find-if #'(lambda (x) (equal '("asdf") - (component-find-path (cdr x)))) - steps) + (find '("asdf") (mapcar 'cdr steps) + :test 'equal :key 'component-find-path) (upgrade-asdf)) ;; If we needed to upgrade ASDF to achieve our goal, ;; then do it specially as the first thing, then @@ -2450,21 +2753,33 @@ created with the same initargs as the original one. ")) (setf (documentation 'oos 'function) (format nil - "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a" + "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" operate-docstring)) (setf (documentation 'operate 'function) operate-docstring)) -(defun* load-system (system &rest args &key force verbose version &allow-other-keys) +(defun* load-system (system &rest keys &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." (declare (ignore force verbose version)) - (apply 'operate 'load-op system args) + (apply 'operate *load-system-operation* system keys) t) +(defun* load-systems (&rest systems) + (map () 'load-system systems)) + +(defun component-loaded-p (c) + (and (gethash 'load-op (component-operation-times (find-component c nil))) t)) + +(defun loaded-systems () + (remove-if-not 'component-loaded-p (registered-systems))) + +(defun require-system (s &rest keys &key &allow-other-keys) + (apply 'load-system s :force-not (loaded-systems) keys)) + (defun* compile-system (system &rest args &key force verbose version &allow-other-keys) - "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE + "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply 'operate 'compile-op system args) @@ -2472,7 +2787,7 @@ for details." (defun* test-system (system &rest args &key force verbose version &allow-other-keys) - "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for + "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply 'operate 'test-op system args) @@ -2484,7 +2799,7 @@ details." (defun* load-pathname () (resolve-symlinks* (or *load-pathname* *compile-file-pathname*))) -(defun* determine-system-pathname (pathname pathname-supplied-p) +(defun* determine-system-pathname (pathname) ;; The defsystem macro calls us to determine ;; the pathname of a system as follows: ;; 1. the one supplied, @@ -2492,12 +2807,15 @@ details." ;; 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* (coerce-pathname pathname :type :directory) - directory-pathname)) + (or (and pathname (subpathname directory-pathname pathname :type :directory)) directory-pathname (default-directory)))) +(defun* find-class* (x &optional (errorp t) environment) + (etypecase x + ((or standard-class built-in-class) x) + (symbol (find-class x errorp environment)))) + (defun* class-for-type (parent type) (or (loop :for symbol :in (list type @@ -2509,8 +2827,10 @@ details." class (find-class 'component))) :return class) (and (eq type :file) - (or (module-default-component-class parent) - (find-class *default-component-class*))) + (find-class* + (or (loop :for module = parent :then (component-parent module) :while module + :thereis (module-default-component-class module)) + *default-component-class*) nil)) (sysdef-error "don't recognize component type ~A" type))) (defun* maybe-add-tree (tree op1 op2 c) @@ -2520,7 +2840,7 @@ Returns the new tree (which probably shares structure with the old one)" (if first-op-tree (progn (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it)) + (if (find c (cdr it) :test #'equal) nil (setf (cdr it) (cons c (cdr it)))) (setf (cdr first-op-tree) @@ -2542,8 +2862,7 @@ Returns the new tree (which probably shares structure with the old one)" (defvar *serial-depends-on* nil) (defun* sysdef-error-component (msg type name value) - (sysdef-error (concatenate 'string msg - (compatfmt "~&~@")) + (sysdef-error (strcat msg (compatfmt "~&~@")) type name value)) (defun* check-component-input (type name weakly-depends-on @@ -2597,10 +2916,10 @@ Returns the new tree (which probably shares structure with the old one)" (type name &rest rest &key ;; the following list of keywords is reproduced below in the ;; remove-keys form. important to keep them in sync - components pathname default-component-class + components pathname perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to + weakly-depends-on depends-on serial in-order-to + do-first (version nil versionp) ;; list ends &allow-other-keys) options @@ -2620,30 +2939,24 @@ Returns the new tree (which probably shares structure with the old one)" (warn (compatfmt "~@") version name parent))) - (let* ((other-args (remove-keys - '(components pathname default-component-class - perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to) - rest)) - (ret - (or (find-component parent name) - (make-instance (class-for-type parent type))))) + (let* ((args (list* :name (coerce-name name) + :pathname pathname + :parent parent + (remove-keys + '(components pathname + perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to) + rest))) + (ret (find-component parent name))) (when weakly-depends-on - (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) + (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) - (apply 'reinitialize-instance ret - :name (coerce-name name) - :pathname pathname - :parent parent - other-args) + (if ret ; preserve identity + (apply 'reinitialize-instance ret args) + (setf ret (apply 'make-instance (class-for-type parent type) args))) (component-pathname ret) ; eagerly compute the absolute pathname (when (typep ret 'module) - (setf (module-default-component-class ret) - (or default-component-class - (and (typep parent 'module) - (module-default-component-class parent)))) (let ((*serial-depends-on* nil)) (setf (module-components ret) (loop @@ -2661,13 +2974,20 @@ Returns the new tree (which probably shares structure with the old one)" in-order-to `((compile-op (compile-op ,@depends-on)) (load-op (load-op ,@depends-on))))) - (setf (component-do-first ret) `((compile-op (load-op ,@depends-on)))) + (setf (component-do-first ret) + (union-of-dependencies + do-first + `((compile-op (load-op ,@depends-on))))) (%refresh-component-inline-methods ret rest) ret))) +(defun* reset-system (system &rest keys &key &allow-other-keys) + (change-class (change-class system 'proto-system) 'system) + (apply 'reinitialize-instance system keys)) + (defun* do-defsystem (name &rest options - &key (pathname nil pathname-arg-p) (class 'system) + &key pathname (class 'system) defsystem-depends-on &allow-other-keys) ;; The system must be registered before we parse the body, ;; otherwise we recur when trying to find an existing system @@ -2678,22 +2998,23 @@ Returns the new tree (which probably shares structure with the old one)" (with-system-definitions () (let* ((name (coerce-name name)) (registered (system-registered-p name)) - (system (cdr (or registered - (register-system (make-instance 'system :name name))))) + (registered! (if registered + (rplaca registered (get-universal-time)) + (register-system (make-instance 'system :name name)))) + (system (reset-system (cdr registered!) + :name name :source-file (load-pathname))) (component-options (remove-keys '(:class) options))) - (%set-system-source-file (load-pathname) system) (setf (gethash name *systems-being-defined*) system) - (when registered - (setf (car registered) (get-universal-time))) - (map () 'load-system defsystem-depends-on) + (apply 'load-systems defsystem-depends-on) ;; We change-class (when necessary) AFTER we load the defsystem-dep's ;; since the class might not be defined as part of those. - (unless (eq (type-of system) class) - (change-class system class)) + (let ((class (class-for-type nil class))) + (unless (eq (type-of system) class) + (change-class system class))) (parse-component-form nil (list* :module name - :pathname (determine-system-pathname pathname pathname-arg-p) + :pathname (determine-system-pathname pathname) component-options))))) (defmacro defsystem (name &body options) @@ -2706,11 +3027,24 @@ Returns the new tree (which probably shares structure with the old one)" ;;;; gratefully accepted, if they do the same thing. ;;;; If the docstring is ambiguous, send a bug report. ;;;; +;;;; WARNING! The function below is mostly dysfunctional. +;;;; For instance, it will probably run fine on most implementations on Unix, +;;;; which will hopefully use the shell /bin/sh (which we force in some cases) +;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell. +;;;; But behavior on Windows may vary wildly between implementations, +;;;; either relying on your having installed a POSIX sh, or going through +;;;; the CMD.EXE interpreter, for a totally different meaning, depending on +;;;; what is easily expressible in said implementation. +;;;; ;;;; We probably should move this functionality to its own system and deprecate ;;;; use of it from the asdf package. However, this would break unspecified ;;;; existing software, so until a clear alternative exists, we can't deprecate ;;;; it, and even after it's been deprecated, we will support it for a few ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 +;;;; +;;;; As a suggested replacement which is portable to all ASDF-supported +;;;; implementations and operating systems except Genera, I recommend +;;;; xcvb-driver's xcvb-driver:run-program/ and its derivatives. (defun* run-shell-command (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and @@ -2726,37 +3060,74 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." ;; will this fail if command has embedded quotes - it seems to work (multiple-value-bind (stdout stderr exit-code) (excl.osi:command-output - (format nil "~a -c \"~a\"" - #+mswindows "sh" #-mswindows "/bin/sh" command) + #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command) + #+mswindows command ; BEWARE! :input nil :whole nil #+mswindows :show-window #+mswindows :hide) - (asdf-message "~{~&; ~a~%~}~%" stderr) - (asdf-message "~{~&; ~a~%~}~%" stdout) + (asdf-message "~{~&~a~%~}~%" stderr) + (asdf-message "~{~&~a~%~}~%" stdout) exit-code) - #+clisp ;XXX not exactly *verbose-out*, I know - (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0) + #+clisp + ;; CLISP returns NIL for exit status zero. + (if *verbose-out* + (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r" + command)) + (outstream (ext:run-shell-command new-command :output :stream :wait t))) + (multiple-value-bind (retval out-lines) + (unwind-protect + (parse-clisp-shell-output outstream) + (ignore-errors (close outstream))) + (asdf-message "~{~&~a~%~}~%" out-lines) + retval)) + ;; there will be no output, just grab up the exit status + (or (ext:run-shell-command command :output nil :wait t) 0)) #+clozure (nth-value 1 (ccl:external-process-status - (ccl:run-program "/bin/sh" (list "-c" command) - :input nil :output *verbose-out* - :wait t))) + (ccl:run-program + (cond + ((os-unix-p) "/bin/sh") + ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE! + (t (error "Unsupported OS"))) + (if (os-unix-p) (list "-c" command) '()) + :input nil :output *verbose-out* :wait t))) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + + #+cormanlisp + (win32:system command) #+ecl ;; courtesy of Juan Jose Garcia Ripoll - (si:system command) + (ext:system command) #+gcl (lisp:system command) #+lispworks - (system:call-system-showing-output - command - :shell-type "/bin/sh" - :show-cmd nil - :prefix "" - :output-stream *verbose-out*) + (apply 'system:call-system-showing-output command + :show-cmd nil :prefix "" :output-stream *verbose-out* + (when (os-unix-p) '(:shell-type "/bin/sh"))) + + #+mcl + (ccl::with-cstrs ((%command command)) (_system %command)) + + #+mkcl + ;; This has next to no chance of working on basic Windows! + ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH. + (multiple-value-bind (io process exit-code) + (apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh" + (list "-c" command) + :input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it + #-windows '(:search nil)) + (declare (ignore io process)) + exit-code) #+sbcl (sb-ext:process-exit-code @@ -2766,19 +3137,31 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." :input nil :output *verbose-out* #+win32 '(:search t) #-win32 nil)) - #+(or cmu scl) - (ext:process-exit-code - (ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out*)) - #+xcl (ext:run-shell-command command) - #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl) (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) +#+clisp +(defun* parse-clisp-shell-output (stream) + "Helper function for running shell commands under clisp. Parses a specially- +crafted output string to recover the exit status of the shell command and a +list of lines of output." + (loop :with status-prefix = "ASDF-EXIT-STATUS " + :with prefix-length = (length status-prefix) + :with exit-status = -1 :with lines = () + :for line = (read-line stream nil nil) + :while line :do (push line lines) :finally + (let* ((last (car lines)) + (status (and last (>= (length last) prefix-length) + (string-equal last status-prefix :end1 prefix-length) + (parse-integer last :start prefix-length :junk-allowed t)))) + (when status + (setf exit-status status) + (pop lines) (when (equal "" (car lines)) (pop lines))) + (return (values exit-status (reverse lines)))))) + ;;;; --------------------------------------------------------------------------- ;;;; system-relative-pathname @@ -2795,18 +3178,22 @@ or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME if that's whay you mean." ;;) (system-source-file x)) +(defmethod system-source-file ((system system)) + ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed + (unless (slot-boundp system 'source-file) + (%set-system-source-file + (probe-asd (component-name system) (component-pathname system)) system)) + (%system-source-file system)) (defmethod system-source-file ((system-name string)) - (system-source-file (find-system system-name))) + (%system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) - (system-source-file (find-system system-name))) + (%system-source-file (find-system system-name))) (defun* system-source-directory (system-designator) "Return a pathname object corresponding to the directory in which the system specification (.asd file) is located." - (make-pathname :name nil - :type nil - :defaults (system-source-file system-designator))) + (pathname-directory-pathname (system-source-file system-designator))) (defun* relativize-directory (directory) (cond @@ -2824,172 +3211,188 @@ located." :defaults p))) (defun* system-relative-pathname (system name &key type) - (merge-pathnames* - (coerce-pathname name :type type) - (system-source-directory system))) + (subpathname (system-source-directory system) name :type type)) ;;; --------------------------------------------------------------------------- ;;; implementation-identifier ;;; ;;; produce a string to identify current implementation. -;;; Initially stolen from SLIME's SWANK, hacked since. - -(defparameter *implementation-features* - '((:abcl :armedbear) - (:acl :allegro) - (:mcl :digitool) ; before clozure, so it won't get preempted by ccl - (:ccl :clozure) - (:corman :cormanlisp) - (:lw :lispworks) - :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl)) - -(defparameter *os-features* - '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows - (:solaris :sunos) - (:linux :linux-target) ;; for GCL at least, must appear before :bsd. - (:macosx :darwin :darwin-target :apple) - :freebsd :netbsd :openbsd :bsd - :unix - :genera)) - -(defparameter *architecture-features* - '((:amd64 :x86-64 :x86_64 :x8664-target) - (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) - :hppa64 :hppa - (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc) - :sparc64 (:sparc32 :sparc) - (:arm :arm-target) - (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7) - :mipsel :mipseb :mips - :alpha - :imach)) - -(defun* lisp-version-string () - (let ((s (lisp-implementation-version))) - (declare (ignorable s)) - #+allegro (format nil - "~A~A~A~A" - excl::*common-lisp-version-number* - ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox - (if (eq excl:*current-case-mode* - :case-sensitive-lower) "M" "A") - ;; Note if not using International ACL - ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm - (excl:ics-target-case - (:-ics "8") - (:+ics "")) - (if (member :64bit *features*) "-64bit" "")) - #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) - #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.) - #+clozure (format nil "~d.~d-f~d" ; shorten for windows - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version* - (logand ccl::fasl-version #xFF)) - #+cmu (substitute #\- #\/ s) - #+ecl (format nil "~A~@[-~A~]" s - (let ((vcs-id (ext:lisp-implementation-vcs-id))) - (when (>= (length vcs-id) 8) - (subseq vcs-id 0 8)))) - #+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 - #+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)) +;;; Initially stolen from SLIME's SWANK, rewritten since. +;;; We're back to runtime checking, for the sake of e.g. ABCL. (defun* first-feature (features) - (labels - ((fp (thing) - (etypecase thing - (symbol - (let ((feature (find thing *features*))) - (when feature (return-from fp feature)))) - ;; allows features to be lists of which the first - ;; member is the "main name", the rest being aliases - (cons - (dolist (subf thing) - (when (find subf *features*) (return-from fp (first thing)))))) - nil)) - (loop :for f :in features - :when (fp f) :return :it))) - -(defun* implementation-type () - (first-feature *implementation-features*)) + (dolist (x features) + (multiple-value-bind (val feature) + (if (consp x) (values (first x) (cons :or (rest x))) (values x x)) + (when (featurep feature) (return val))))) + +(defun implementation-type () + (first-feature + '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu + :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl))) + +(defun operating-system () + (first-feature + '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! + (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd + (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd + (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix + :genera))) + +(defun architecture () + (first-feature + '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386)) + (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) + (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) + :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) + :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach + ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, + ;; we may have to segregate the code still by architecture. + (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) + +#+clozure +(defun* ccl-fasl-version () + ;; the fasl version is target-dependent from CCL 1.8 on. + (or (let ((s 'ccl::target-fasl-version)) + (and (fboundp s) (funcall s))) + (and (boundp 'ccl::fasl-version) + (symbol-value 'ccl::fasl-version)) + (error "Can't determine fasl version."))) + +(defun lisp-version-string () + (let ((s (lisp-implementation-version))) + (car ; as opposed to OR, this idiom prevents some unreachable code warning + (list + #+allegro + (format nil "~A~@[~A~]~@[~A~]~@[~A~]" + excl::*common-lisp-version-number* + ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default) + (and (eq excl:*current-case-mode* :case-sensitive-lower) "M") + ;; Note if not using International ACL + ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm + (excl:ics-target-case (:-ics "8")) + (and (member :smp *features*) "S")) + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + #+clisp + (subseq s 0 (position #\space s)) ; strip build information (date, etc.) + #+clozure + (format nil "~d.~d-f~d" ; shorten for windows + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand (ccl-fasl-version) #xFF)) + #+cmu (substitute #\- #\/ s) + #+scl (format nil "~A~A" s + ;; ANSI upper case vs lower case. + (ecase ext:*case-mode* (:upper "") (:lower "l"))) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (subseq vcs-id 0 (min (length vcs-id) 8)))) + #+gcl (subseq s (1+ (position #\space s))) + #+genera + (multiple-value-bind (major minor) (sct:get-system-version "System") + (format nil "~D.~D" major minor)) + #+mcl (subseq s 8) ; strip the leading "Version " + s)))) (defun* implementation-identifier () - (labels - ((maybe-warn (value fstring &rest args) - (cond (value) - (t (apply 'warn fstring args) - "unknown")))) - (let ((lisp (maybe-warn (implementation-type) - (compatfmt "~@") - *implementation-features*)) - (os (maybe-warn (first-feature *os-features*) - (compatfmt "~@") *os-features*)) - (arch (or #-clisp - (maybe-warn (first-feature *architecture-features*) - (compatfmt "~@") - *architecture-features*))) - (version (maybe-warn (lisp-version-string) - "Don't know how to get Lisp implementation version."))) - (substitute-if - #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\"")) - (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch))))) + (substitute-if + #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) + (format nil "~(~a~@{~@[-~a~]~}~)" + (or (implementation-type) (lisp-implementation-type)) + (or (lisp-version-string) (lisp-implementation-version)) + (or (operating-system) (software-type)) + (or (architecture) (machine-type))))) + +(defun* hostname () + ;; Note: untested on RMCL + #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) + #+cormanlisp "localhost" ;; is there a better way? Does it matter? + #+allegro (excl.osi:gethostname) + #+clisp (first (split-string (machine-instance) :separator " ")) + #+gcl (system:gethostname)) ;;; --------------------------------------------------------------------------- ;;; Generic support for configuration files -(defparameter *inter-directory-separator* - #+asdf-unix #\: - #-asdf-unix #\;) +(defun inter-directory-separator () + (if (os-unix-p) #\: #\;)) (defun* user-homedir () - (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* (coerce-pathname sub :type type) p))) - (ts (and sp (probe-file* sp)))) - (and ts (values sp ts)))) + (truenamize + (pathname-directory-pathname + #+cormanlisp (ensure-directory-pathname (user-homedir-pathname)) + #+mcl (current-user-homedir-pathname) + #-(or cormanlisp mcl) (user-homedir-pathname)))) + +(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args) + (when (plusp (length x)) + (let ((p (if want-directory (ensure-directory-pathname x) (pathname x)))) + (when want-absolute + (unless (absolute-pathname-p p) + (cerror "ignore relative pathname" + "Invalid relative pathname ~A~@[ ~?~]" x fmt args) + (return-from ensure-pathname* nil))) + p))) +(defun* split-pathnames* (x want-absolute want-directory fmt &rest args) + (loop :for dir :in (split-string + x :separator (string (inter-directory-separator))) + :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args))) +(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x))) + (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x)) +(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x))) + (and (plusp (length s)) + (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s))) +(defun* getenv-absolute-directory (x) + (getenv-pathname x :want-absolute t :want-directory t)) +(defun* getenv-absolute-directories (x) + (getenv-pathnames x :want-absolute t :want-directory t)) + +(defun* get-folder-path (folder) + (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path + #+(and lispworks mswindows) (sys:get-folder-path folder) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + (ecase folder + (:local-appdata (getenv-absolute-directory "LOCALAPPDATA")) + (:appdata (getenv-absolute-directory "APPDATA")) + (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) + (defun* user-configuration-directories () - (remove-if - #'null - (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) - `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") - ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") - :for dir :in (split-string dirs :separator ":") - :collect (try dir "common-lisp/")) - #+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/")) - ,(try (user-homedir) ".config/common-lisp/"))))) + (let ((dirs + `(,@(when (os-unix-p) + (cons + (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/") + (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS") + :collect (subpathname* dir "common-lisp/")))) + ,@(when (os-windows-p) + `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/") + ,(subpathname* (get-folder-path :appdata) "common-lisp/config/"))) + ,(subpathname (user-homedir) ".config/common-lisp/")))) + (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) + :from-end t :test 'equal))) + (defun* system-configuration-directories () - (remove-if - #'null - (append - #+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 - :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) -(defun* in-user-configuration-directory (x) - (in-first-directory (user-configuration-directories) x)) -(defun* in-system-configuration-directory (x) - (in-first-directory (system-configuration-directories) x)) + (cond + ((os-unix-p) '(#p"/etc/common-lisp/")) + ((os-windows-p) + (aif + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData + (subpathname* (get-folder-path :common-appdata) "common-lisp/config/") + (list it))))) + +(defun* in-first-directory (dirs x &key (direction :input)) + (loop :with fun = (ecase direction + ((nil :input :probe) 'probe-file*) + ((:output :io) 'identity)) + :for dir :in dirs + :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir)))))) + +(defun* in-user-configuration-directory (x &key (direction :input)) + (in-first-directory (user-configuration-directories) x :direction direction)) +(defun* in-system-configuration-directory (x &key (direction :input)) + (in-first-directory (system-configuration-directories) x :direction direction)) (defun* configuration-inheritance-directive-p (x) (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) @@ -3054,7 +3457,8 @@ located." #+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)))))) + #+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 @@ -3098,14 +3502,12 @@ and the order is by decreasing length of namestring of the source pathname.") (defvar *user-cache* (flet ((try (x &rest sub) (and x `(,x ,@sub)))) (or - (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) - #+asdf-windows - (try (getenv "APPDATA") "common-lisp" "cache" :implementation) + (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation) + (when (os-windows-p) + (try (or (get-folder-path :local-appdata) + (get-folder-path :appdata)) + "common-lisp" "cache" :implementation)) '(:home ".cache" "common-lisp" :implementation)))) -(defvar *system-cache* - ;; No good default, plus there's a security problem - ;; with other users messing with such directories. - *user-cache*) (defun* output-translations () (car *output-translations*)) @@ -3136,35 +3538,34 @@ with a different configuration, so the configuration would be re-read then." (values (or null pathname) &optional)) resolve-location)) -(defun* resolve-relative-location-component (super x &key directory wilden) - (let* ((r (etypecase x - (pathname x) - (string x) - (cons - (return-from resolve-relative-location-component - (if (null (cdr x)) +(defun* resolve-relative-location-component (x &key directory wilden) + (let ((r (etypecase x + (pathname x) + (string (coerce-pathname x :type (when directory :directory))) + (cons + (if (null (cdr x)) + (resolve-relative-location-component + (car x) :directory directory :wilden wilden) + (let* ((car (resolve-relative-location-component + (car x) :directory t :wilden nil))) + (merge-pathnames* (resolve-relative-location-component - super (car x) :directory directory :wilden wilden) - (let* ((car (resolve-relative-location-component - super (car x) :directory t :wilden nil)) - (cdr (resolve-relative-location-component - (merge-pathnames* car super) (cdr x) - :directory directory :wilden wilden))) - (merge-pathnames* cdr car))))) - ((eql :default-directory) - (relativize-pathname-directory (default-directory))) - ((eql :*/) *wild-directory*) - ((eql :**/) *wild-inferiors*) - ((eql :*.*.*) *wild-file*) - ((eql :implementation) (implementation-identifier)) - ((eql :implementation-type) (string-downcase (implementation-type))) - #+asdf-unix - ((eql :uid) (princ-to-string (get-uid))))) - (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r))) - (s (if (or (pathnamep x) (not wilden)) d (wilden d)))) - (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) - (error (compatfmt "~@") s super)) - (merge-pathnames* s super))) + (cdr x) :directory directory :wilden wilden) + car)))) + ((eql :default-directory) + (relativize-pathname-directory (default-directory))) + ((eql :*/) *wild-directory*) + ((eql :**/) *wild-inferiors*) + ((eql :*.*.*) *wild-file*) + ((eql :implementation) + (coerce-pathname (implementation-identifier) :type :directory)) + ((eql :implementation-type) + (coerce-pathname (string-downcase (implementation-type)) :type :directory)) + ((eql :hostname) + (coerce-pathname (hostname) :type :directory))))) + (when (absolute-pathname-p r) + (error (compatfmt "~@") x)) + (if (or (pathnamep x) (not wilden)) r (wilden r)))) (defvar *here-directory* nil "This special variable is bound to the currect directory during calls to @@ -3175,17 +3576,19 @@ directive.") (let* ((r (etypecase x (pathname x) - (string (if directory (ensure-directory-pathname x) (parse-namestring x))) + (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x))) + #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) + (if directory (ensure-directory-pathname p) p))) (cons (return-from resolve-absolute-location-component (if (null (cdr x)) (resolve-absolute-location-component (car x) :directory directory :wilden wilden) - (let* ((car (resolve-absolute-location-component - (car x) :directory t :wilden nil)) - (cdr (resolve-relative-location-component - car (cdr x) :directory directory :wilden wilden))) - (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ? + (merge-pathnames* + (resolve-relative-location-component + (cdr x) :directory directory :wilden wilden) + (resolve-absolute-location-component + (car x) :directory t :wilden nil))))) ((eql :root) ;; special magic! we encode such paths as relative pathnames, ;; but it means "relative to the root of the source pathname's host and device". @@ -3199,13 +3602,15 @@ directive.") :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 :system-cache) + (error "Using the :system-cache is deprecated. ~%~ +Please remove it from your ASDF configuration")) ((eql :default-directory) (default-directory)))) (s (if (and wilden (not (pathnamep x))) (wilden r) r))) (unless (absolute-pathname-p s) - (error (compatfmt "~@") s)) + (error (compatfmt "~@") x)) s)) (defun* resolve-location (x &key directory wilden) @@ -3217,8 +3622,10 @@ directive.") :for (component . morep) :on (cdr x) :for dir = (and (or morep directory) t) :for wild = (and wilden (not morep)) - :do (setf path (resolve-relative-location-component - path component :directory dir :wilden wild)) + :do (setf path (merge-pathnames* + (resolve-relative-location-component + component :directory dir :wilden wild) + path)) :finally (return path)))) (defun* location-designator-p (x) @@ -3228,21 +3635,19 @@ directive.") (relative-component-p (c) (typep c '(or string pathname (member :default-directory :*/ :**/ :*.*.* - :implementation :implementation-type - #+asdf-unix :uid))))) + :implementation :implementation-type))))) (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 - (consp x) (length=n-p x 2) - (or (and (equal (first x) :function) - (typep (second x) 'symbol)) - (and (equal (first x) 'lambda) - (cddr x) - (length=n-p (second x) 2))))) + (eq (car x) :function) + (or (symbolp (cadr x)) + (and (consp (cadr x)) + (eq (caadr x) 'lambda) + (length=n-p (cadadr x) 2))))) (defun* validate-output-translations-directive (directive) (or (member directive '(:enable-user-cache :disable-cache nil)) @@ -3289,7 +3694,8 @@ directive.") :with start = 0 :with end = (length string) :with source = nil - :for i = (or (position *inter-directory-separator* string :start start) end) :do + :with separator = (inter-directory-separator) + :for i = (or (position separator string :start start) end) :do (let ((s (subseq string start i))) (cond (source @@ -3323,10 +3729,12 @@ directive.") `(: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)) `((,(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 + #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t))) + (when h `((,(truenamize h) ,*wild-inferiors*) ()))) + ;; The below two are not needed: no precompiled ASDF system there + #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ()) + #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) + ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; These are for convenience, and can be overridden by the user: @@ -3338,14 +3746,14 @@ directive.") (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*)) -(defun* system-output-translations-pathname () - (in-system-configuration-directory *output-translations-file*)) -(defun* user-output-translations-directory-pathname () - (in-user-configuration-directory *output-translations-directory*)) -(defun* system-output-translations-directory-pathname () - (in-system-configuration-directory *output-translations-directory*)) +(defun* user-output-translations-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-file* :direction direction)) +(defun* system-output-translations-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-file* :direction direction)) +(defun* user-output-translations-directory-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-directory* :direction direction)) +(defun* system-output-translations-directory-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-directory* :direction direction)) (defun* environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) @@ -3413,8 +3821,9 @@ directive.") ((eq dst t) (funcall collect (list trusrc t))) (t - (let* ((trudst (make-pathname - :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) + (let* ((trudst (if dst + (resolve-location dst :directory t :wilden t) + trusrc)) (wilddst (merge-pathnames* *wild-file* trudst))) (funcall collect (list wilddst t)) (funcall collect (list trusrc trudst))))))))))) @@ -3467,8 +3876,8 @@ effectively disabling the output translation facility." (translate-pathname path absolute-source destination)))) (defun* apply-output-translations (path) + #+cormanlisp (truenamize path) #-cormanlisp (etypecase path - #+cormanlisp (t (truenamize path)) (logical-pathname path) ((or pathname string) @@ -3489,7 +3898,7 @@ effectively disabling the output translation facility." (defmethod output-files :around (operation component) "Translate output files, unless asked not to" - (declare (ignorable operation component)) + operation component ;; hush genera, not convinced by declare ignorable(!) (values (multiple-value-bind (files fixedp) (call-next-method) (if fixedp @@ -3498,27 +3907,32 @@ effectively disabling the output translation facility." t)) (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) - (or output-file + (if (absolute-pathname-p output-file) + ;; what cfp should be doing, w/ mp* instead of mp + (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys))) + (defaults (make-pathname + :type type :defaults (merge-pathnames* input-file)))) + (merge-pathnames* output-file defaults)) (apply-output-translations - (apply 'compile-file-pathname - (truenamize (lispize-pathname input-file)) - keys)))) + (apply 'compile-file-pathname input-file + (if output-file keys (remove-keyword :output-file keys)))))) (defun* tmpize-pathname (x) (make-pathname - :name (format nil "ASDF-TMP-~A" (pathname-name x)) + :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x)) (defun* delete-file-if-exists (x) (when (and x (probe-file* x)) (delete-file x))) -(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) - (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys))) +(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys) + (let* ((keywords (remove-keyword :compile-check keys)) + (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords)) (tmp-file (tmpize-pathname output-file)) (status :error)) (multiple-value-bind (output-truename warnings-p failure-p) - (apply 'compile-file input-file :output-file tmp-file keys) + (apply 'compile-file input-file :output-file tmp-file keywords) (cond (failure-p (setf status *compile-file-failure-behaviour*)) @@ -3526,15 +3940,19 @@ effectively disabling the output translation facility." (setf status *compile-file-warnings-behaviour*)) (t (setf status :success))) - (ecase status - ((:success :warn :ignore) + (cond + ((and (ecase status + ((:success :warn :ignore) t) + ((:error nil))) + (or (not compile-check) + (apply compile-check input-file :output-file tmp-file keywords))) (delete-file-if-exists output-file) (when output-truename (rename-file output-truename output-file) (setf output-truename output-file))) - (:error + (t ;; error or failed check (delete-file-if-exists output-truename) - (setf output-truename nil))) + (setf output-truename nil failure-p t))) (values output-truename warnings-p failure-p)))) #+abcl @@ -3570,18 +3988,16 @@ call that function where you would otherwise have loaded and configured A-B-L.") (&key (centralize-lisp-binaries nil) (default-toplevel-directory - ;; Use ".cache/common-lisp" instead ??? - (merge-pathnames* (make-pathname :directory '(:relative ".fasls")) - (user-homedir))) + (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? (include-per-user-information nil) - (map-all-source-files (or #+(or ecl clisp) t nil)) + (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) (source-to-target-mappings nil)) - #+(or ecl clisp) + #+(or clisp ecl mkcl) (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")) + (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) (mapped-files (if map-all-source-files *wild-file* - (make-pathname :name :wild :version :wild :type fasl-type))) + (make-pathname :type fasl-type :defaults *wild-file*))) (destination-directory (if centralize-lisp-binaries `(,default-toplevel-directory @@ -3598,82 +4014,6 @@ call that function where you would otherwise have loaded and configured A-B-L.") :ignore-inherited-configuration)))) ;;;; ----------------------------------------------------------------- -;;;; Windows shortcut support. Based on: -;;;; -;;;; Jesse Hager: The Windows Shortcut File Format. -;;;; http://www.wotsit.org/list.asp?fc=13 - -#+(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)) - -(defun* read-null-terminated-string (s) - (with-output-to-string (out) - (loop :for code = (read-byte s) - :until (zerop code) - :do (write-char (code-char code) out)))) - -(defun* read-little-endian (s &optional (bytes 4)) - (loop - :for i :from 0 :below bytes - :sum (ash (read-byte s) (* 8 i)))) - -(defun* parse-file-location-info (s) - (let ((start (file-position s)) - (total-length (read-little-endian s)) - (end-of-header (read-little-endian s)) - (fli-flags (read-little-endian s)) - (local-volume-offset (read-little-endian s)) - (local-offset (read-little-endian s)) - (network-volume-offset (read-little-endian s)) - (remaining-offset (read-little-endian s))) - (declare (ignore total-length end-of-header local-volume-offset)) - (unless (zerop fli-flags) - (cond - ((logbitp 0 fli-flags) - (file-position s (+ start local-offset))) - ((logbitp 1 fli-flags) - (file-position s (+ start - network-volume-offset - #x14)))) - (concatenate 'string - (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) - -(defun* parse-windows-shortcut (pathname) - (with-open-file (s pathname :element-type '(unsigned-byte 8)) - (handler-case - (when (and (= (read-little-endian s) *link-initial-dword*) - (let ((header (make-array (length *link-guid*)))) - (read-sequence header s) - (equalp header *link-guid*))) - (let ((flags (read-little-endian s))) - (file-position s 76) ;skip rest of header - (when (logbitp 0 flags) - ;; skip shell item id list - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (cond - ((logbitp 1 flags) - (parse-file-location-info s)) - (t - (when (logbitp 2 flags) - ;; skip description string - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (when (logbitp 3 flags) - ;; finally, our pathname - (let* ((length (read-little-endian s 2)) - (buffer (make-array length))) - (read-sequence buffer s) - (map 'string #'code-char buffer))))))) - (end-of-file () - nil))))) - -;;;; ----------------------------------------------------------------- ;;;; Source Registry Configuration, by Francois-Rene Rideau ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 @@ -3683,7 +4023,7 @@ call that function where you would otherwise have loaded and configured A-B-L.") ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build" - "debian")) ;; debian often build stuff under the debian directory... BAD. + "debian")) ;; debian often builds stuff under the debian directory... BAD. (defvar *source-registry-exclusions* *default-source-registry-exclusions*) @@ -3704,49 +4044,95 @@ with a different configuration, so the configuration would be re-read then." (defparameter *wild-asd* (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) -(defun directory-asd-files (directory) - (ignore-errors - (directory* (merge-pathnames* *wild-asd* directory)))) - -(defun subdirectories (directory) +(defun* filter-logical-directory-results (directory entries merger) + (if (typep directory 'logical-pathname) + ;; Try hard to not resolve logical-pathname into physical pathnames; + ;; otherwise logical-pathname users/lovers will be disappointed. + ;; If directory* could use some implementation-dependent magic, + ;; we will have logical pathnames already; otherwise, + ;; we only keep pathnames for which specifying the name and + ;; translating the LPN commute. + (loop :for f :in entries + :for p = (or (and (typep f 'logical-pathname) f) + (let* ((u (ignore-errors (funcall merger f)))) + ;; The first u avoids a cumbersome (truename u) error. + ;; At this point f should already be a truename, + ;; but isn't quite in CLISP, for doesn't have :version :newest + (and u (equal (ignore-errors (truename u)) (truename f)) u))) + :when p :collect p) + entries)) + +(defun* directory-files (directory &optional (pattern *wild-file*)) + (let ((dir (pathname directory))) + (when (typep dir 'logical-pathname) + ;; Because of the filtering we do below, + ;; logical pathnames have restrictions on wild patterns. + ;; Not that the results are very portable when you use these patterns on physical pathnames. + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) + (filter-logical-directory-results + directory entries + #'(lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical (pathname-name f)) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f)))))))) + +(defun* directory-asd-files (directory) + (directory-files directory *wild-asd*)) + +(defun* subdirectories (directory) (let* ((directory (ensure-directory-pathname directory)) - #-(or cormanlisp genera xcl) + #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks scl xcl) + #-(or abcl allegro cmu lispworks sbcl scl xcl) *wild-directory* - #+(or abcl allegro cmu lispworks scl xcl) "*.*" + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" directory)) (dirs - #-(or cormanlisp genera xcl) + #-(or abcl cormanlisp genera xcl) (ignore-errors (directory* wild . #.(or #+clozure '(:directories t :files nil) #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) - #+genera (fs:directory-list directory) - #+xcl (system:list-directory directory)) - #+(or abcl allegro cmu genera lispworks scl xcl) + #+genera (fs:directory-list directory)) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) (dirs (loop :for x :in dirs :for d = #+(or abcl xcl) (extensions:probe-directory x) #+allegro (excl:probe-directory x) - #+(or cmu scl) (directory-pathname-p x) + #+(or cmu sbcl scl) (directory-pathname-p x) #+genera (getf (cdr x) :directory) #+lispworks (lw:file-directory-p x) :when d :collect #+(or abcl allegro xcl) d #+genera (ensure-directory-pathname (first x)) - #+(or cmu lispworks scl) x))) - dirs)) - -(defun collect-asds-in-directory (directory collect) + #+(or cmu lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) + '(:absolute)))) ; because allegro returns NIL for #p"FOO:" + #'(lambda (d) + (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory (append prefix (make-pathname-component-logical (last dir))))))))))) + +(defun* collect-asds-in-directory (directory collect) (map () collect (directory-asd-files directory))) -(defun collect-sub*directories (directory collectp recursep collector) +(defun* collect-sub*directories (directory collectp recursep collector) (when (funcall collectp directory) (funcall collector directory)) (dolist (subdir (subdirectories directory)) (when (funcall recursep subdir) (collect-sub*directories subdir collectp recursep collector)))) -(defun collect-sub*directories-asd-files +(defun* collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect) @@ -3797,19 +4183,24 @@ with a different configuration, so the configuration would be re-read then." :with directives = () :with start = 0 :with end = (length string) - :for pos = (position *inter-directory-separator* string :start start) :do + :with separator = (inter-directory-separator) + :for pos = (position separator string :start start) :do (let ((s (subseq string start (or pos end)))) - (cond - ((equal "" s) ; empty element: inherit - (when inherit - (error (compatfmt "~@") - string)) - (setf inherit t) - (push ':inherit-configuration directives)) - ((ends-with s "//") - (push `(:tree ,(subseq s 0 (1- (length s)))) directives)) - (t - (push `(:directory ,s) directives))) + (flet ((check (dir) + (unless (absolute-pathname-p dir) + (error (compatfmt "~@") string)) + dir)) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error (compatfmt "~@") + string)) + (setf inherit t) + (push ':inherit-configuration directives)) + ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? + (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) + (t + (push `(:directory ,(check s)) directives)))) (cond (pos (setf start (1+ pos))) @@ -3837,43 +4228,35 @@ with a different configuration, so the configuration would be re-read then." (defun* wrapping-source-registry () `(:source-registry - #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME"))) + #+ecl (:tree ,(translate-logical-pathname "SYS:")) + #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) + #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t))) :inherit-configuration - #+cmu (:tree #p"modules:"))) + #+cmu (:tree #p"modules:") + #+scl (:tree #p"file://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 ,(default-directory)) - ,@(let* - #+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 ":")))) - #+asdf-windows - ((datahome (getenv "APPDATA")) - (datadir - #+lispworks (sys:get-folder-path :local-appdata) - #-lispworks (try (getenv "ALLUSERSPROFILE") - "Application Data")) - (dirs (list datahome datadir))) - #-(or asdf-unix asdf-windows) - ((dirs ())) - (loop :for dir :in dirs - :collect `(:directory ,(try dir "common-lisp/systems/")) - :collect `(:tree ,(try dir "common-lisp/source/")))) - :inherit-configuration))) -(defun* user-source-registry () - (in-user-configuration-directory *source-registry-file*)) -(defun* system-source-registry () - (in-system-configuration-directory *source-registry-file*)) -(defun* user-source-registry-directory () - (in-user-configuration-directory *source-registry-directory*)) -(defun* system-source-registry-directory () - (in-system-configuration-directory *source-registry-directory*)) + `(:source-registry + #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) + (:directory ,(default-directory)) + ,@(loop :for dir :in + `(,@(when (os-unix-p) + `(,(or (getenv-absolute-directory "XDG_DATA_HOME") + (subpathname (user-homedir) ".local/share/")) + ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") + '("/usr/local/share" "/usr/share")))) + ,@(when (os-windows-p) + (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata)))) + :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) + :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) + :inherit-configuration)) +(defun* user-source-registry (&key (direction :input)) + (in-user-configuration-directory *source-registry-file* :direction direction)) +(defun* system-source-registry (&key (direction :input)) + (in-system-configuration-directory *source-registry-file* :direction direction)) +(defun* user-source-registry-directory (&key (direction :input)) + (in-user-configuration-directory *source-registry-directory* :direction direction)) +(defun* system-source-registry-directory (&key (direction :input)) + (in-system-configuration-directory *source-registry-directory* :direction direction)) (defun* environment-source-registry () (getenv "CL_SOURCE_REGISTRY")) @@ -3948,19 +4331,26 @@ with a different configuration, so the configuration would be re-read then." ,parameter ,@*default-source-registries*) :register #'(lambda (directory &key recurse exclude) - (collect (list directory :recurse recurse :exclude exclude))))) - :test 'equal :from-end t))) + (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. +;; Will read the configuration and initialize all internal variables. (defun* compute-source-registry (&optional parameter (registry *source-registry*)) (dolist (entry (flatten-source-registry parameter)) (destructuring-bind (directory &key recurse exclude) entry - (let* ((h (make-hash-table :test 'equal))) + (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates (register-asd-directory directory :recurse recurse :exclude exclude :collect #'(lambda (asd) - (let ((name (pathname-name asd))) + (let* ((name (pathname-name asd)) + (name (if (typep asd 'logical-pathname) + ;; logical pathnames are upper-case, + ;; at least in the CLHS and on SBCL, + ;; yet (coerce-name :foo) is lower-case. + ;; won't work well with (load-system "Foo") + ;; instead of (load-system 'foo) + (string-downcase name) + name))) (cond ((gethash name registry) ; already shadowed by something else nil) @@ -4004,50 +4394,60 @@ with a different configuration, so the configuration would be re-read then." (clear-output-translations)) -;;; ECL support for COMPILE-OP / LOAD-OP +;;; ECL and MKCL support for COMPILE-OP / LOAD-OP ;;; -;;; In ECL, these operations produce both FASL files and the -;;; object files that they are built from. Having both of them allows -;;; us to later on reuse the object files for bundles, libraries, -;;; standalone executables, etc. +;;; In ECL and MKCL, these operations produce both +;;; FASL files and the object files that they are built from. +;;; Having both of them allows us to later on reuse the object files +;;; for bundles, libraries, standalone executables, etc. ;;; ;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes ;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp. ;;; -#+ecl -(progn - (setf *compile-op-compile-file-function* - (lambda (input-file &rest keys &key output-file &allow-other-keys) - (declare (ignore output-file)) - (multiple-value-bind (object-file flags1 flags2) - (apply 'compile-file* input-file :system-p t keys) - (values (and object-file - (c::build-fasl (compile-file-pathname object-file :type :fasl) - :lisp-files (list object-file)) - object-file) - flags1 - flags2)))) - - (defmethod output-files ((operation compile-op) (c cl-source-file)) - (declare (ignorable operation)) - (let ((p (lispize-pathname (component-pathname c)))) - (list (compile-file-pathname p :type :object) - (compile-file-pathname p :type :fasl)))) - - (defmethod perform ((o load-op) (c cl-source-file)) - (map () #'load - (loop :for i :in (input-files o c) - :unless (string= (pathname-type i) "fas") - :collect (compile-file-pathname (lispize-pathname i)))))) +;;; Also, register-pre-built-system. -;;;; ----------------------------------------------------------------- -;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL +#+(or ecl mkcl) +(progn + (defun register-pre-built-system (name) + (register-system (make-instance 'system :name (coerce-name name) :source-file nil))) + + #+(or (and ecl win32) (and mkcl windows)) + (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal) + (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source)))) + + (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* + (loop :for f :in #+ecl ext:*module-provider-functions* + #+mkcl mk-ext::*module-provider-functions* + :unless (eq f 'module-provide-asdf) + :collect #'(lambda (name) + (let ((l (multiple-value-list (funcall f name)))) + (and (first l) (register-pre-built-system (coerce-name name))) + (values-list l))))) + + (setf *compile-op-compile-file-function* 'compile-file-keeping-object) + + (defun compile-file-keeping-object (input-file &rest keys &key &allow-other-keys) + (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys) + #+mkcl progn + (multiple-value-bind (object-file flags1 flags2) + (apply 'compile-file* input-file + #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil keys) + (values (and object-file + (compiler::build-fasl + (compile-file-pathname object-file + #+ecl :type #+ecl :fasl #+mkcl :fasl-p #+mkcl t) + #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file)) + object-file) + flags1 + flags2))))) + +;;;; ----------------------------------------------------------------------- +;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL ;;;; -(defvar *require-asdf-operator* 'load-op) - (defun* module-provide-asdf (name) (handler-bind ((style-warning #'muffle-warning) + #-genera (missing-component (constantly nil)) (error #'(lambda (e) (format *error-output* (compatfmt "~@~%") @@ -4055,18 +4455,18 @@ with a different configuration, so the configuration would be re-read then." (let ((*verbose-out* (make-broadcast-stream)) (system (find-system (string-downcase name) nil))) (when system - (operate *require-asdf-operator* system :verbose nil) + (require-system system :verbose nil) t)))) -#+(or abcl clisp clozure cmu ecl sbcl) +#+(or abcl clisp clozure cmu ecl mkcl sbcl) (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom)))) (when x (eval `(pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions* #+clisp ,x #+clozure ccl:*module-provider-functions* - #+cmu ext:*module-provider-functions* - #+ecl si:*module-provider-functions* + #+(or cmu ecl) ext:*module-provider-functions* + #+mkcl mk-ext:*module-provider-functions* #+sbcl sb-ext:*module-provider-functions*)))) @@ -4086,6 +4486,21 @@ with a different configuration, so the configuration would be re-read then." (when *load-verbose* (asdf-message ";; ASDF, version ~a~%" (asdf-version))) +#+mkcl +(progn + (defvar *loading-asdf-bundle* nil) + (unless *loading-asdf-bundle* + (let ((*central-registry* + (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*)) + (*loading-asdf-bundle* t)) + (clear-system :asdf-bundle) ;; we hope to force a reload. + (multiple-value-bind (result bundling-error) + (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle)) + (unless result + (format *error-output* + "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%" + bundling-error)))))) + #+allegro (eval-when (:compile-toplevel :execute) (when (boundp 'excl:*warn-on-nested-reader-conditionals*)