-;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.019: 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 <asdf-devel@common-lisp.net>.
;;; 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
#+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)
+#-(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
+(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
- #+ecl (unless (member :ecl-bytecmp *features*) (require :cmp))
#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
(when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
(and (= system::*gcl-major-version* 2)
(< system::*gcl-minor-version* 7)))
(pushnew :gcl-pre2.7 *features*))
+ #+(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)
(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.
;; "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.019")
+ (asdf-version "2.26")
(existing-asdf (find-class 'component nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
(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-symbol* sym package))
(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 redefined-functions)
+ #-cmu (ensure-fmakunbound p redefined-functions)
p)))
(macrolet
((pkgdcl (name &key nicknames use export
: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
(#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
#:system-definition-pathname #:with-system-definitions
#:search-for-system-definition #:find-component #:component-find-path
- #:compile-system #:load-system #:load-systems #:test-system #:clear-system
+ #: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
+ #:implementation-identifier #:implementation-type #:hostname
#:input-files #:output-files #:output-file #:perform
#:operation-done-p #:explain
#:unix-dso
#:module-components ; component accessors
- #:module-components-by-name ; component accessors
+ #:module-components-by-name
#:component-pathname
#:component-relative-pathname
#:component-name
#:component-parent
#:component-property
#:component-system
-
#:component-depends-on
+ #:component-encoding
+ #:component-external-format
#:system-description
#:system-long-description
#: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*
- #:*require-asdf-operator*
+ #:*load-system-operation*
#:*asdf-verbose*
#:*verbose-out*
#: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
#:clear-source-registry
#:ensure-source-registry
#:process-source-registry
- #:system-registered-p
+ #:system-registered-p #:registered-systems #:loaded-systems
+ #:resolve-location
#:asdf-message
#:user-output-translations-pathname
#:system-output-translations-pathname
#:user-source-registry-directory
#:system-source-registry-directory
- ;; Utilities
- #:absolute-pathname-p
+ ;; Utilities: please use asdf-utils instead
+ #|
;; #:aif #:it
;; #: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
- ;; #:length=n-p
- ;; #:find-symbol*
- #:merge-pathnames* #:coerce-pathname #:subpathname
- #: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
(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*
(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))))
(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)
(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)))
(error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") 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)
:do (pop reldir) (pop defrev)
:finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
-(defun* ununspecific (x)
- (if (eq x :unspecific) nil x))
+(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
(type (or (pathname-type specified) (pathname-type defaults)))
(version (or (pathname-version specified) (pathname-version defaults))))
(labels ((unspecific-handler (p)
- (if (typep p 'logical-pathname) #'ununspecific #'identity)))
+ (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
(multiple-value-bind (host device directory unspecific-handler)
(ecase (first directory)
((:absolute)
(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 "")
(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)
(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
((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))))
(null nil)
(string (probe-file* (parse-namestring p)))
(pathname (unless (wild-pathname-p p)
- #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
+ #.(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)))
(host (pathname-host pathname))
(port (ext:pathname-port pathname))
(directory (pathname-directory pathname)))
- (if (or (ununspecific port)
- (and (ununspecific host) (plusp (length host)))
- (ununspecific scheme))
+ (flet ((specificp (x) (and x (not (eq x :unspecific)))))
+ (if (or (specificp port)
+ (and (specificp host) (plusp (length host)))
+ (specificp scheme))
(let ((prefix ""))
- (when (ununspecific port)
+ (when (specificp port)
(setf prefix (format nil ":~D" port)))
- (when (and (ununspecific host) (plusp (length host)))
+ (when (and (specificp host) (plusp (length host)))
(setf prefix (strcat host prefix)))
(setf prefix (strcat ":" prefix))
- (when (ununspecific scheme)
+ (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))
+ pathname)))
;;;; -------------------------------------------------------------------------
;;;; ASDF Interface, in terms of generic functions.
(defgeneric* (setf component-property) (new-value component property))
+(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)))
;;;; -------------------------------------------------------------------------
;;; 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
;; 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)
(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
: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)))
(acons property new-value (slot-value c 'properties)))))
new-value)
+(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 "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") 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.
(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)))
(defun* probe-asd (name defaults)
(block nil
(when (directory-pathname-p defaults)
- (let ((file (make-pathname
- :defaults defaults :name name
- :version :newest :case :local :type "asd")))
- (when (probe-file* file)
+ (let* ((file (probe-file* (subpathname defaults (strcat name ".asd")))))
+ (when file
(return file)))
#-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
(when (os-windows-p)
:condition condition))))
(let ((*package* package)
(*default-pathname-defaults*
- (pathname-directory-pathname pathname)))
+ ;; 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)))))
(defun* locate-system (name)
"Given a system NAME designator, try to locate where to load the system from.
-Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
-FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
+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, associated with FOUND-SYSTEM, or with the PREVIOUS system.
+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))
(previous (cdr in-memory))
(previous (and (typep previous 'system) previous))
(previous-time (car in-memory))
- (found (search-for-system-definition name))
+ (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))
(error 'missing-component :requires name))))))
(reinitialize-source-registry-and-retry ()
:report (lambda (s)
- (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
+ (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
(initialize-source-registry))))))
(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
(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
- (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)
:type (source-file-type component (component-system component))
:defaults (component-parent-pathname component)))
-(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)))
-
;;;; -------------------------------------------------------------------------
;;;; Operations
;; 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)
(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)
comp))
(retry ()
:report (lambda (s)
- (format s "~@<Retry loading ~3i~_~A.~@:>" name))
+ (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
:test
(lambda (c)
(or (null c)
(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.
: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.
(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))
(first files)))
(defun* ensure-all-directories-exist (pathnames)
- (loop :for pn :in pathnames
- :for pathname = (if (typep pn 'logical-pathname)
- (translate-logical-pathname pn)
- pn)
- :do (ensure-directories-exist pathname)))
+ (dolist (pathname pathnames)
+ (ensure-directories-exist (translate-logical-pathname pathname))))
(defmethod perform :before ((operation compile-op) (c source-file))
- (ensure-all-directories-exist (asdf:output-files operation c)))
+ (ensure-all-directories-exist (output-files operation c)))
(defmethod perform :after ((operation operation) (c component))
(mark-operation-done operation c))
(funcall (ensure-function hook) thunk)
(funcall thunk))))
-(defvar *compile-op-compile-file-function* 'compile-file*
- "Function used to compile lisp files.")
-
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(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.
(*compile-file-failure-behaviour* (operation-on-failure operation)))
(multiple-value-bind (output warnings-p failure-p)
(call-with-around-compile-hook
- c #'(lambda ()
+ c #'(lambda (&rest flags)
(apply *compile-op-compile-file-function* source-file
- :output-file output-file (compile-op-flags operation))))
+ :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
(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))
(perform (make-sub-operation c o c 'compile-op) c)))))
(defmethod perform ((o load-op) (c cl-source-file))
- (map () #'load (input-files o c)))
+ (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))
(declare (ignorable o))
(let ((source (component-pathname c)))
(setf (component-property c 'last-loaded-as-source)
- (and (call-with-around-compile-hook c #'(lambda () (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))
;;;; Separating this into a different function makes it more forward-compatible
(defun* cleanup-upgraded-asdf (old-version)
- (let ((new-version (asdf:asdf-version)))
+ (let ((new-version (asdf-version)))
(unless (equal old-version new-version)
(cond
((version-satisfies new-version old-version)
;;;; 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))
(cleanup-upgraded-asdf version)))
(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)
(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)
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
class (find-class 'component)))
:return class)
(and (eq type :file)
- (or (and parent (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)
(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 do-first
+ weakly-depends-on depends-on serial in-order-to
+ do-first
(version nil versionp)
;; list ends
&allow-other-keys) options
:pathname pathname
:parent parent
(remove-keys
- '(components pathname default-component-class
+ '(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))
(if ret ; preserve identity
(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
;;;;
;;;; 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/process-output-stream and its
-;;;; derivatives such as xcvb-driver:run-program/for-side-effects.
+;;;; 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
#+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
(apply 'sb-ext:run-program
#+xcl
(ext:run-shell-command command)
- #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl 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
(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)))
(defun implementation-type ()
(first-feature
'(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
- :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl)))
+ :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl)))
(defun operating-system ()
(first-feature
;; 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~]"
+ (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")
+ ;; 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")))
+ (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.)
(format nil "~d.~d-f~d" ; shorten for windows
ccl::*openmcl-major-version*
ccl::*openmcl-minor-version*
- (logand ccl::fasl-version #xFF))
+ (logand (ccl-fasl-version) #xFF))
#+cmu (substitute #\- #\/ s)
#+scl (format nil "~A~A" s
;; ANSI upper case vs lower case.
(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
(defun* user-homedir ()
(truenamize
(pathname-directory-pathname
+ #+cormanlisp (ensure-directory-pathname (user-homedir-pathname))
#+mcl (current-user-homedir-pathname)
- #-mcl (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 ()
(let ((dirs
`(,@(when (os-unix-p)
(cons
- (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/")
- (loop :with dirs = (getenv "XDG_CONFIG_DIRS")
- :for dir :in (split-string dirs :separator ":")
+ (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* (or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv "LOCALAPPDATA"))
- "common-lisp/config/")
- ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
- ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
- (getenv "APPDATA"))
- "common-lisp/config/")))
+ `(,(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)))
((os-windows-p)
(aif
;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
- (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
- (getenv "ALLUSERSAPPDATA")
- (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))
- "common-lisp/config/")
+ (subpathname* (get-folder-path :common-appdata) "common-lisp/config/")
(list it)))))
(defun* in-first-directory (dirs x &key (direction :input))
(defvar *user-cache*
(flet ((try (x &rest sub) (and x `(,x ,@sub))))
(or
- (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
+ (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
(when (os-windows-p)
- (try (or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv "LOCALAPPDATA")
- #+lispworks (sys:get-folder-path :appdata)
- (getenv "APPDATA"))
+ (try (or (get-folder-path :local-appdata)
+ (get-folder-path :appdata))
"common-lisp" "cache" :implementation))
'(:home ".cache" "common-lisp" :implementation))))
((eql :implementation)
(coerce-pathname (implementation-identifier) :type :directory))
((eql :implementation-type)
- (coerce-pathname (string-downcase (implementation-type)) :type :directory)))))
+ (coerce-pathname (string-downcase (implementation-type)) :type :directory))
+ ((eql :hostname)
+ (coerce-pathname (hostname) :type :directory)))))
(when (absolute-pathname-p r)
(error (compatfmt "~@<pathname ~S is not relative~@:>") x))
(if (or (pathnamep x) (not wilden)) r (wilden r))))
(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))
`(: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*) ())))
+ #+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
- ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
+ #+(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
:type type :defaults (merge-pathnames* input-file))))
(merge-pathnames* output-file defaults))
(apply-output-translations
- (apply 'compile-file-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
(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 (apply 'compile-file-pathname* input-file :output-file output-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*))
(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
(default-toplevel-directory
(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 :type fasl-type :defaults *wild-file*)))
(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
- (and u (equal (ignore-errors (truename u)) f) u)))
+ ;; 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*))
- (when (wild-pathname-p directory)
- (error "Invalid wild in ~S" directory))
- (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
- (error "Invalid file pattern ~S" pattern))
- (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
- (filter-logical-directory-results
- directory entries
- #'(lambda (f)
- (make-pathname :defaults directory
- :name (pathname-name f) :type (ununspecific (pathname-type f))
- :version (ununspecific (pathname-version f)))))))
+ (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*))
#+(or cmu lispworks sbcl scl) x)))
(filter-logical-directory-results
directory dirs
- (let ((prefix (normalize-pathname-directory-component
- (pathname-directory directory))))
+ (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))))
+ (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
(and (consp dir) (consp (cdr dir))
(make-pathname
:defaults directory :name nil :type nil :version nil
- :directory (append prefix (last dir))))))))))
+ :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
(defun* collect-asds-in-directory (directory collect)
(map () collect (directory-asd-files directory)))
string))
(setf inherit t)
(push ':inherit-configuration directives))
- ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
+ ((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))))
(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:")
#+scl (:tree #p"file://modules/")))
`(:source-registry
#+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
(:directory ,(default-directory))
- ,@(loop :for dir :in
- `(,@(when (os-unix-p)
- `(,(or (getenv "XDG_DATA_HOME")
- (subpathname (user-homedir) ".local/share/"))
- ,@(split-string (or (getenv "XDG_DATA_DIRS")
- "/usr/local/share:/usr/share")
- :separator ":")))
- ,@(when (os-windows-p)
- `(,(or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv "LOCALAPPDATA"))
- ,(or #+lispworks (sys:get-folder-path :appdata)
- (getenv "APPDATA"))
- ,(or #+lispworks (sys:get-folder-path :common-appdata)
- (getenv "ALLUSERSAPPDATA")
- (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")))))
- :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
- :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
- :inherit-configuration))
+ ,@(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))
,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.
(defun* compute-source-registry (&optional parameter (registry *source-registry*))
(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* 'ecl-compile-file)
-
- (defun use-ecl-byte-compiler-p ()
- (member :ecl-bytecmp *features*))
-
- (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
- (if (use-ecl-byte-compiler-p)
- (apply 'compile-file* input-file keys)
- (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)))
- (f (compile-file-pathname p :type :fasl)))
- (if (use-ecl-byte-compiler-p)
- (list f)
- (list (compile-file-pathname p :type :object) f))))
-
- (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)
(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
#+clisp ,x
#+clozure ccl:*module-provider-functions*
#+(or cmu ecl) ext:*module-provider-functions*
+ #+mkcl mk-ext:*module-provider-functions*
#+sbcl sb-ext:*module-provider-functions*))))
(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*)
projects / sbcl.git / blobdiff