Changeset 13655


Ignore:
Timestamp:
10/21/11 20:55:25 (9 years ago)
Author:
Mark Evenson
Message:

Upgrade to ASDF 2.0.17.022

Location:
trunk/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/doc/asdf/asdf.texinfo

    r13417 r13655  
    518518
    519519@section Configuring where ASDF stores object files
    520 @findex clear-output-locations
     520@findex clear-output-translations
    521521
    522522ASDF lets you configure where object files will be stored.
     
    596596@node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top
    597597@comment  node-name,  next,  previous,  up
     598
     599
     600@section Resetting Configuration
     601
     602When you dump and restore an image, or when you tweak your configuration,
     603you may want to reset the ASDF configuration.
     604For that you may use the following function:
     605
     606@defun clear-configuration
     607   undoes any ASDF configuration,
     608   regarding source-registry or output-translations.
     609@end defun
     610
     611If you use SBCL, CMUCL or SCL, you may use this snippet
     612so that the ASDF configuration be cleared automatically as you dump an image:
     613
     614@example
     615#+(or cmu sbcl scl)
     616(pushnew 'clear-configuration
     617         #+(or cmu scl) ext:*before-save-initializations*
     618         #+sbcl sb-ext:*save-hooks*)
     619@end example
     620
     621For compatibility with all Lisp implementations, however,
     622you might want instead your build script to explicitly call
     623@code{(asdf:clear-configuration)} at an appropriate moment before dumping.
     624
    598625
    599626@chapter Using ASDF
     
    12111238* Operations::
    12121239* Components::
     1240* Functions::
    12131241@end menu
    12141242
     
    14111439CL stream @code{*standard-output*}, as the Lisp compiler and loader do.
    14121440
    1413 @node Components,  , Operations, The object model of ASDF
     1441@node Components, Functions, Operations, The object model of ASDF
    14141442@comment  node-name,  next,  previous,  up
    14151443@section Components
     
    15741602(this-op {(other-op required-components)}+)
    15751603
    1576 required-components := component-name
     1604simple-component-name := string
     1605                      |  symbol
     1606
     1607required-components := simple-component-name
    15771608                     | (required-components required-components)
    15781609
    1579 component-name := string
    1580                 | (:version string minimum-version-object)
     1610component-name := simple-component-name
     1611                | (:version simple-component-name minimum-version-object)
    15811612@end verbatim
    15821613
     
    17881819    )
    17891820@end lisp
     1821
     1822@node Functions,  , Components, The object model of ASDF
     1823@comment  node-name,  next,  previous,  up
     1824@section Functions
     1825@findex version-satisfies
     1826
     1827@deffn version-satisfies @var{version} @var{version-spec}
     1828Does @var{version} satisfy the @var{version-spec}.  A generic function.
     1829ASDF provides built-in methods for @var{version} being a
     1830@code{component} or @code{string}.  @var{version-spec} should be a
     1831string.
     1832
     1833In the wild, we typically see version numbering only on components of
     1834type @code{system}.
     1835
     1836For more information about how @code{version-satisfies} interprets
     1837version strings and specifications, @pxref{The defsystem grammar} and
     1838@ref{Common attributes of components}.
     1839@end deffn
    17901840
    17911841@node Controlling where ASDF searches for systems, Controlling where ASDF saves compiled files, The object model of ASDF, Top
     
    27752825@chapter Miscellaneous additional functionality
    27762826
    2777 @emph{FIXME:  Add discussion of @code{run-shell-command}?  Others?}
    2778 
    27792827ASDF includes several additional features that are generally
    2780 useful for system definition and development. These include:
     2828useful for system definition and development.
     2829
     2830@section Controlling file compilation
     2831
     2832When declaring a component (system, module, file),
     2833you can specify a keyword argument @code{:around-compile some-symbol}.
     2834If left unspecified, the value will be inherited from the parent component if any,
     2835or with a default of @code{nil} if no value is specified in any transitive parent.
     2836
     2837The argument must be a either fbound symbol or @code{nil}.
     2838@code{nil} means the normal compile-file function will be called.
     2839A symbol means the function fbound to it will be called with a single argument,
     2840a thunk that calls the compile-file function;
     2841the function you specify must then funcall that thunk
     2842inside whatever wrapping you want.
     2843
     2844Using this hook, you may achieve such effects as:
     2845locally renaming packages,
     2846binding @var{*readtables*} and other syntax-controlling variables,
     2847handling warnings and other conditions,
     2848proclaiming consistent optimization settings,
     2849saving code coverage information,
     2850maintaining meta-data about compilation timings,
     2851setting gensym counters and PRNG seeds and other sources of non-determinism,
     2852overriding the source-location and/or timestamping systems,
     2853checking that some compile-time side-effects were properly balanced,
     2854etc.
     2855
     2856
     2857@section Miscellaneous Exported Functions
    27812858
    27822859@defun coerce-pathname name @&key type defaults
     
    28722949look at the beginning of @file{asdf.lisp} to see what it does.
    28732950@end defun
     2951
     2952@defun run-shell-command
     2953
     2954This function is obsolete and present only for the sake of backwards-compatibility:
     2955``If it's not backwards, it's not compatible''. We strongly discourage its use.
     2956Its current behavior is only well-defined on Unix platforms
     2957(which includes MacOS X and cygwin). On Windows, anything goes.
     2958
     2959Instead we recommend the use of such a function as
     2960@code{xcvb-driver:run-program/process-output-stream}
     2961from the @code{xcvb-driver} system that is distributed with XCVB:
     2962@url{http://common-lisp.net/project/xcvb}.
     2963It's only alternative that supports
     2964as many implementations and operating systems as ASDF does,
     2965and provides well-defined behavior outside Unix (i.e. on Windows).
     2966(The only unsupported exception is Genera, since on it
     2967@code{run-shell-command} doesn't make sense anyway on that platform).
     2968
     2969This function takes as arguments a @code{format} control-string
     2970and arguments to be passed to @code{format} after this control-string
     2971to produce a string.
     2972This string is a command that will be evaluated with a POSIX shell if possible;
     2973yet, on Windows, some implementations will use CMD.EXE,
     2974while others (like SBCL) will make an attempt at invoking a POSIX shell
     2975(and fail if it is not present).
     2976@end defun
     2977
    28742978
    28752979@node Getting the latest version, FAQ, Miscellaneous additional functionality, Top
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r13417 r13655  
    1 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.017: Another System Definition Facility.
     1;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
     2;;; This is ASDF 2.017.22: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    6262        (remove "asdf" excl::*autoload-package-name-alist*
    6363                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
    64   #+(and ecl (not ecl-bytecmp)) (require :cmp)
     64  #+ecl (unless (member :ecl-bytecmp *features*) (require :cmp))
    6565  #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
    6666  (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
     
    6868                 (< system::*gcl-minor-version* 7)))
    6969    (pushnew :gcl-pre2.7 *features*))
    70   #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
    71   #+(or unix cygwin) (pushnew :asdf-unix *features*)
    7270  ;;; make package if it doesn't exist yet.
    7371  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
     
    113111         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    114112         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    115          (asdf-version "2.017")
     113         (asdf-version "2.017.22")
    116114         (existing-asdf (find-class 'component nil))
    117115         (existing-version *asdf-version*)
     
    201199               (loop :for x :in newly-exported-symbols :do
    202200                 (export (intern* x package)))))
    203            (ensure-package (name &key nicknames use unintern fmakunbound
    204         shadow export redefined-functions)
     201           (ensure-package (name &key nicknames use unintern
     202                                shadow export redefined-functions)
    205203             (let* ((p (ensure-exists name nicknames use)))
    206204               (ensure-unintern p unintern)
    207205               (ensure-shadow p shadow)
    208206               (ensure-export p export)
    209                (ensure-fmakunbound p (append fmakunbound redefined-functions))
     207               (ensure-fmakunbound p redefined-functions)
    210208               p)))
    211209        (macrolet
    212210            ((pkgdcl (name &key nicknames use export
    213                            redefined-functions unintern fmakunbound shadow)
     211                           redefined-functions unintern shadow)
    214212                 `(ensure-package
    215213                   ',name :nicknames ',nicknames :use ',use :export ',export
    216214                   :shadow ',shadow
    217215                   :unintern ',unintern
    218        :redefined-functions ',redefined-functions
    219                    :fmakunbound ',fmakunbound)))
     216                   :redefined-functions ',redefined-functions)))
    220217          (pkgdcl
    221218           :asdf
     
    227224            #:system-source-file #:operate #:find-component #:find-system
    228225            #:apply-output-translations #:translate-pathname* #:resolve-location
     226            #:system-relative-pathname
     227            #:inherit-source-registry #:process-source-registry
     228            #:process-source-registry-directive
    229229            #:compile-file* #:source-file-type)
    230230           :unintern
     
    232232            #:split #:make-collector
    233233            #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
    234            :fmakunbound
    235            (#:system-source-file
    236             #:component-relative-pathname #:system-relative-pathname
    237             #:process-source-registry
    238             #:inherit-source-registry #:process-source-registry-directive)
    239234           :export
    240235           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
     
    299294            #:*compile-file-failure-behaviour*
    300295            #:*resolve-symlinks*
     296            #:*require-asdf-operator*
    301297            #:*asdf-verbose*
     298            #:*verbose-out*
    302299
    303300            #:asdf-version
     
    676673(defun* getenv (x)
    677674  (declare (ignorable x))
    678   #+(or abcl clisp xcl) (ext:getenv x)
     675  #+(or abcl clisp ecl xcl) (ext:getenv x)
    679676  #+allegro (sys:getenv x)
    680677  #+clozure (ccl:getenv x)
     
    690687      (ct:free buffer)
    691688      (ct:free buffer1)))
    692   #+ecl (si:getenv x)
    693689  #+gcl (system:getenv x)
    694690  #+genera nil
     
    923919(defgeneric* perform (operation component))
    924920(defgeneric* operation-done-p (operation component))
     921(defgeneric* mark-operation-done (operation component))
    925922(defgeneric* explain (operation component))
    926923(defgeneric* output-files (operation component))
     
    11671164   ;; it to default in funky ways if not supplied
    11681165   (relative-pathname :initarg :pathname)
     1166   ;; the absolute-pathname is computed based on relative-pathname...
    11691167   (absolute-pathname)
    11701168   (operation-times :initform (make-hash-table)
    11711169                    :accessor component-operation-times)
     1170   (around-compile :initarg :around-compile)
    11721171   ;; XXX we should provide some atomic interface for updating the
    11731172   ;; component properties
    11741173   (properties :accessor component-properties :initarg :properties
    11751174               :initform nil)))
     1175
     1176;;; I believe that the following could probably be more efficiently done
     1177;;; by a primary method that invokes SHARED-INITIALIZE in a way that would
     1178;;; appropriately pass the slots to have their initforms re-applied, but I
     1179;;; do not know how to write such a method. [2011/09/02:rpg]
     1180(defmethod reinitialize-instance :after ((obj component) &rest initargs
     1181                                         &key (version nil version-suppliedp)
     1182                                              (description nil description-suppliedp)
     1183                                              (long-description nil
     1184                                                                long-description-suppliedp)
     1185                                              (load-dependencies nil
     1186                                                                 ld-suppliedp)
     1187                                              in-order-to
     1188                                              do-first
     1189                                              inline-methods
     1190                                              parent
     1191                                              properties)
     1192  "We reuse component objects from previously-existing systems, so we need to
     1193make sure we clear them thoroughly."
     1194  (declare (ignore initargs load-dependencies
     1195                   long-description description version))
     1196  ;; this is a cache and should be cleared
     1197  (slot-makunbound obj 'absolute-pathname)
     1198  ;; component operation times are no longer valid when the component changes
     1199  (clrhash (component-operation-times obj))
     1200  (unless version-suppliedp (slot-makunbound obj 'version))
     1201  (unless description-suppliedp
     1202    (slot-makunbound obj 'description))
     1203  (unless long-description-suppliedp
     1204    (slot-makunbound obj 'long-description))
     1205  ;; replicate the logic of the initforms...
     1206  (unless ld-suppliedp
     1207    (setf (component-load-dependencies obj) nil))
     1208  (setf (component-in-order-to obj) in-order-to
     1209        (component-do-first obj) do-first
     1210        (component-inline-methods obj) inline-methods
     1211        (slot-value obj 'parent) parent
     1212        (slot-value obj 'properties) properties))
     1213
    11761214
    11771215(defun* component-find-path (component)
     
    12471285    :accessor module-default-component-class)))
    12481286
     1287;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
     1288;;; [2011/09/02:rpg]
     1289(defmethod reinitialize-instance :after ((obj module) &rest initargs &key)
     1290  "Clear MODULE's slots so it can be reused."
     1291  (slot-makunbound obj 'components-by-name)
     1292  ;; this may be a more elegant approach than in the
     1293  ;; COMPONENT method [2011/09/02:rpg]
     1294  (loop :for (initarg slot-name default) :in
     1295        `((:components components nil)
     1296          (:if-component-dep-fails if-component-dep-fails :fail)
     1297          (:default-component-class default-component-class
     1298              ,*default-component-class*))
     1299        :unless (member initarg initargs)
     1300        :do (setf (slot-value obj slot-name) default)))
     1301
    12491302(defun* component-parent-pathname (component)
    12501303  ;; No default anymore (in particular, no *default-pathname-defaults*).
     
    12891342   (licence :accessor system-licence :initarg :licence
    12901343            :accessor system-license :initarg :license)
    1291    (source-file :reader system-source-file :initarg :source-file
     1344   (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
    12921345                :writer %set-system-source-file)
    12931346   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
     1347
     1348;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
     1349;;; [2011/09/02:rpg]
     1350(defmethod reinitialize-instance :after ((obj system) &rest initargs &key)
     1351  "Clear SYSTEM's slots so it can be reused."
     1352  ;; note that SYSTEM-SOURCE-FILE is very specially handled,
     1353  ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and
     1354  ;; not squash it.  SYSTEM COMPONENTS are handled very specially,
     1355  ;; because they are always, effectively, reused, since the system component
     1356  ;; is made early in DO-DEFSYSTEM, instead of being made later, in
     1357  ;; PARSE-COMPONENT-FORM [2011/09/02:rpg]
     1358  (loop :for (initarg slot-name) :in
     1359        `((:author author)
     1360          (:maintainer maintainer)
     1361          (:licence licence)
     1362          (:defsystem-depends-on defsystem-depends-on))
     1363        :unless (member initarg initargs)
     1364        :do (slot-makunbound obj slot-name)))
    12941365
    12951366;;;; -------------------------------------------------------------------------
     
    13411412           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    13421413
     1414;;;; -----------------------------------------------------------------
     1415;;;; Windows shortcut support.  Based on:
     1416;;;;
     1417;;;; Jesse Hager: The Windows Shortcut File Format.
     1418;;;; http://www.wotsit.org/list.asp?fc=13
     1419
     1420#-clisp
     1421(progn
     1422(defparameter *link-initial-dword* 76)
     1423(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
     1424
     1425(defun* read-null-terminated-string (s)
     1426  (with-output-to-string (out)
     1427    (loop :for code = (read-byte s)
     1428      :until (zerop code)
     1429      :do (write-char (code-char code) out))))
     1430
     1431(defun* read-little-endian (s &optional (bytes 4))
     1432  (loop :for i :from 0 :below bytes
     1433    :sum (ash (read-byte s) (* 8 i))))
     1434
     1435(defun* parse-file-location-info (s)
     1436  (let ((start (file-position s))
     1437        (total-length (read-little-endian s))
     1438        (end-of-header (read-little-endian s))
     1439        (fli-flags (read-little-endian s))
     1440        (local-volume-offset (read-little-endian s))
     1441        (local-offset (read-little-endian s))
     1442        (network-volume-offset (read-little-endian s))
     1443        (remaining-offset (read-little-endian s)))
     1444    (declare (ignore total-length end-of-header local-volume-offset))
     1445    (unless (zerop fli-flags)
     1446      (cond
     1447        ((logbitp 0 fli-flags)
     1448          (file-position s (+ start local-offset)))
     1449        ((logbitp 1 fli-flags)
     1450          (file-position s (+ start
     1451                              network-volume-offset
     1452                              #x14))))
     1453      (concatenate 'string
     1454        (read-null-terminated-string s)
     1455        (progn
     1456          (file-position s (+ start remaining-offset))
     1457          (read-null-terminated-string s))))))
     1458
     1459(defun* parse-windows-shortcut (pathname)
     1460  (with-open-file (s pathname :element-type '(unsigned-byte 8))
     1461    (handler-case
     1462        (when (and (= (read-little-endian s) *link-initial-dword*)
     1463                   (let ((header (make-array (length *link-guid*))))
     1464                     (read-sequence header s)
     1465                     (equalp header *link-guid*)))
     1466          (let ((flags (read-little-endian s)))
     1467            (file-position s 76)        ;skip rest of header
     1468            (when (logbitp 0 flags)
     1469              ;; skip shell item id list
     1470              (let ((length (read-little-endian s 2)))
     1471                (file-position s (+ length (file-position s)))))
     1472            (cond
     1473              ((logbitp 1 flags)
     1474                (parse-file-location-info s))
     1475              (t
     1476                (when (logbitp 2 flags)
     1477                  ;; skip description string
     1478                  (let ((length (read-little-endian s 2)))
     1479                    (file-position s (+ length (file-position s)))))
     1480                (when (logbitp 3 flags)
     1481                  ;; finally, our pathname
     1482                  (let* ((length (read-little-endian s 2))
     1483                         (buffer (make-array length)))
     1484                    (read-sequence buffer s)
     1485                    (map 'string #'code-char buffer)))))))
     1486      (end-of-file ()
     1487        nil)))))
     1488
    13431489;;;; -------------------------------------------------------------------------
    13441490;;;; Finding systems
     
    14211567")
    14221568
     1569(defun* featurep (x &optional (features *features*))
     1570  (cond
     1571    ((atom x)
     1572     (and (member x features) t))
     1573    ((eq 'not (car x))
     1574     (assert (null (cddr x)))
     1575     (not (featurep (cadr x) features)))
     1576    ((eq 'or (car x))
     1577     (some #'(lambda (x) (featurep x features)) (cdr x)))
     1578    ((eq 'and (car x))
     1579     (every #'(lambda (x) (featurep x features)) (cdr x)))
     1580    (t
     1581     (error "Malformed feature specification ~S" x))))
     1582
     1583(defun* os-unix-p ()
     1584  (featurep '(or :unix :cygwin :darwin)))
     1585
     1586(defun* os-windows-p ()
     1587  (and (not (os-unix-p)) (featurep '(or :win32 :windows :mswindows :mingw32))))
     1588
    14231589(defun* probe-asd (name defaults)
    14241590  (block nil
     
    14291595        (when (probe-file* file)
    14301596          (return file)))
    1431       #+(and asdf-windows (not clisp))
    1432       (let ((shortcut
    1433              (make-pathname
    1434               :defaults defaults :version :newest :case :local
    1435               :name (concatenate 'string name ".asd")
    1436               :type "lnk")))
    1437         (when (probe-file* shortcut)
    1438           (let ((target (parse-windows-shortcut shortcut)))
    1439             (when target
    1440               (return (pathname target)))))))))
     1597      #-clisp
     1598      (when (os-windows-p)
     1599        (let ((shortcut
     1600               (make-pathname
     1601                :defaults defaults :version :newest :case :local
     1602                :name (concatenate 'string name ".asd")
     1603                :type "lnk")))
     1604          (when (probe-file* shortcut)
     1605            (let ((target (parse-windows-shortcut shortcut)))
     1606              (when target
     1607                (return (pathname target))))))))))
    14411608
    14421609(defun* sysdef-central-registry-search (system)
     
    15391706                                  :name name :pathname pathname
    15401707                                  :condition condition))))
    1541              (let ((*package* package))
     1708             (let ((*package* package)
     1709                   (*default-pathname-defaults*
     1710                    (pathname-directory-pathname pathname)))
    15421711               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
    15431712                             pathname package)
     
    18522021         (and op-time (>= op-time (latest-in))))
    18532022        ((not in-files)
    1854          ;; an operation without output-files and no input-files
     2023         ;; an operation with output-files and no input-files
    18552024         ;; is probably meant for its side-effects on the file-system,
    18562025         ;; assumed to have to be done everytime.
     
    18942063(defgeneric* do-traverse (operation component collect))
    18952064
    1896 (defun* %do-one-dep (operation c collect required-op required-c required-v)
    1897   ;; collects a partial plan that results from performing required-op
    1898   ;; on required-c, possibly with a required-vERSION
    1899   (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
    1900                       (and d (version-satisfies d required-v) d))
    1901                     (if required-v
    1902                         (error 'missing-dependency-of-version
    1903                                :required-by c
    1904                                :version required-v
    1905                                :requires required-c)
    1906                         (error 'missing-dependency
    1907                                :required-by c
    1908                                :requires required-c))))
    1909          (op (make-sub-operation c operation dep-c required-op)))
    1910     (do-traverse op dep-c collect)))
    1911 
    1912 (defun* do-one-dep (operation c collect required-op required-c required-v)
    1913   ;; this function is a thin, error-handling wrapper around %do-one-dep.
    1914   ;; Collects a partial plan per that function.
     2065(defun* resolve-dependency-name (component name &optional version)
    19152066  (loop
    19162067    (restart-case
    1917         (return (%do-one-dep operation c collect
    1918                              required-op required-c required-v))
     2068        (return
     2069          (let ((comp (find-component (component-parent component) name)))
     2070            (unless comp
     2071              (error 'missing-dependency
     2072                     :required-by component
     2073                     :requires name))
     2074            (when version
     2075              (unless (version-satisfies comp version)
     2076                (error 'missing-dependency-of-version
     2077                       :required-by component
     2078                       :version version
     2079                       :requires name)))
     2080            comp))
    19192081      (retry ()
    19202082        :report (lambda (s)
    1921                   (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))
     2083                  (format s "~@<Retry loading ~3i~_~A.~@:>" name))
    19222084        :test
    19232085        (lambda (c)
    19242086          (or (null c)
    19252087              (and (typep c 'missing-dependency)
    1926                    (equalp (missing-requires c)
    1927                            required-c))))))))
    1928 
    1929 (defun* do-dep (operation c collect op dep)
    1930   ;; type of arguments uncertain:
    1931   ;; op seems to at least potentially be a symbol, rather than an operation
    1932   ;; dep is a list of component names
    1933   (cond ((eq op 'feature)
    1934          (if (member (car dep) *features*)
     2088                   (eq (missing-required-by c) component)
     2089                   (equal (missing-requires c) name))))))))
     2090
     2091(defun* resolve-dependency-spec (component dep-spec)
     2092  (cond
     2093    ((atom dep-spec)
     2094     (resolve-dependency-name component dep-spec))
     2095    ;; Structured dependencies --- this parses keywords.
     2096    ;; The keywords could conceivably be broken out and cleanly (extensibly)
     2097    ;; processed by EQL methods. But for now, here's what we've got.
     2098    ((eq :version (first dep-spec))
     2099     ;; https://bugs.launchpad.net/asdf/+bug/527788
     2100     (resolve-dependency-name component (second dep-spec) (third dep-spec)))
     2101    ((eq :feature (first dep-spec))
     2102     ;; This particular subform is not documented and
     2103     ;; has always been broken in the past.
     2104     ;; Therefore no one uses it, and I'm cerroring it out,
     2105     ;; after fixing it
     2106     ;; See https://bugs.launchpad.net/asdf/+bug/518467
     2107     (cerror "Continue nonetheless."
     2108             "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
     2109     (when (find (second dep-spec) *features* :test 'string-equal)
     2110       (resolve-dependency-name component (third dep-spec))))
     2111    (t
     2112     (error (compatfmt "~@<Bad dependency ~s.  Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
     2113
     2114(defun* do-one-dep (op c collect dep-op dep-c)
     2115  ;; Collects a partial plan for performing dep-op on dep-c
     2116  ;; as dependencies of a larger plan involving op and c.
     2117  ;; Returns t if this should force recompilation of those who depend on us.
     2118  ;; dep-op is an operation class name (not an operation object),
     2119  ;; whereas dep-c is a component object.n
     2120  (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
     2121
     2122(defun* do-dep (op c collect dep-op-spec dep-c-specs)
     2123  ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
     2124  ;; as dependencies of a larger plan involving op and c.
     2125  ;; Returns t if this should force recompilation of those who depend on us.
     2126  ;; dep-op-spec is either an operation class name (not an operation object),
     2127  ;; or the magic symbol asdf:feature.
     2128  ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
     2129  ;; and the plan will succeed if that keyword is present in *feature*,
     2130  ;; or fail if it isn't
     2131  ;; (at which point c's :if-component-dep-fails will kick in).
     2132  ;; If dep-op-spec is an operation class name,
     2133  ;; then dep-c-specs specifies a list of sibling component of c,
     2134  ;; as per resolve-dependency-spec, such that operating op on c
     2135  ;; depends on operating dep-op-spec on each of them.
     2136  (cond ((eq dep-op-spec 'feature)
     2137         (if (member (car dep-c-specs) *features*)
    19352138             nil
    19362139             (error 'missing-dependency
    19372140                    :required-by c
    1938                     :requires (car dep))))
     2141                    :requires (list :feature (car dep-c-specs)))))
    19392142        (t
    19402143         (let ((flag nil))
    1941            (flet ((dep (op comp ver)
    1942                     (when (do-one-dep operation c collect
    1943                                       op comp ver)
    1944                       (setf flag t))))
    1945              (dolist (d dep)
    1946                (if (atom d)
    1947                    (dep op d nil)
    1948                    ;; structured dependencies --- this parses keywords
    1949                    ;; the keywords could be broken out and cleanly (extensibly)
    1950                    ;; processed by EQL methods
    1951                    (cond ((eq :version (first d))
    1952                           ;; https://bugs.launchpad.net/asdf/+bug/527788
    1953                           (dep op (second d) (third d)))
    1954                          ;; This particular subform is not documented and
    1955                          ;; has always been broken in the past.
    1956                          ;; Therefore no one uses it, and I'm cerroring it out,
    1957                          ;; after fixing it
    1958                          ;; See https://bugs.launchpad.net/asdf/+bug/518467
    1959                          ((eq :feature (first d))
    1960                           (cerror "Continue nonetheless."
    1961                                   "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
    1962                           (when (find (second d) *features* :test 'string-equal)
    1963                             (dep op (third d) nil)))
    1964                          (t
    1965                           (error (compatfmt "~@<Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d))))))
     2144           (dolist (d dep-c-specs)
     2145             (when (do-one-dep op c collect dep-op-spec
     2146                               (resolve-dependency-spec c d))
     2147               (setf flag t)))
    19662148           flag))))
    19672149
     
    20882270  nil)
    20892271
     2272(defmethod mark-operation-done ((operation operation) (c component))
     2273  (setf (gethash (type-of operation) (component-operation-times c))
     2274    (reduce #'max
     2275            (cons (get-universal-time)
     2276                  (mapcar #'safe-file-write-date (input-files operation c))))))
     2277
     2278(defmethod perform-with-restarts (operation component)
     2279  ;; TOO verbose, especially as the default. Add your own :before method
     2280  ;; to perform-with-restart or perform if you want that:
     2281  #|(when *asdf-verbose* (explain operation component))|#
     2282  (perform operation component))
     2283
     2284(defmethod perform-with-restarts :around (operation component)
     2285  (loop
     2286    (restart-case
     2287        (return (call-next-method))
     2288      (retry ()
     2289        :report
     2290        (lambda (s)
     2291          (format s (compatfmt "~@<Retry ~A.~@:>")
     2292                  (operation-description operation component))))
     2293      (accept ()
     2294        :report
     2295        (lambda (s)
     2296          (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
     2297                  (operation-description operation component)))
     2298        (mark-operation-done operation component)
     2299        (return)))))
     2300
    20902301(defmethod explain ((operation operation) (component component))
    20912302  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
     
    21142325    (first files)))
    21152326
     2327(defun* ensure-all-directories-exist (pathnames)
     2328   (loop :for pn :in pathnames
     2329     :for pathname = (if (typep pn 'logical-pathname)
     2330                         (translate-logical-pathname pn)
     2331                         pn)
     2332     :do (ensure-directories-exist pathname)))
     2333
    21162334(defmethod perform :before ((operation compile-op) (c source-file))
    2117    (loop :for file :in (asdf:output-files operation c)
    2118      :for pathname = (if (typep file 'logical-pathname)
    2119                          (translate-logical-pathname file)
    2120                          file)
    2121      :do (ensure-directories-exist pathname)))
     2335  (ensure-all-directories-exist (asdf:output-files operation c)))
    21222336
    21232337(defmethod perform :after ((operation operation) (c component))
    2124   (setf (gethash (type-of operation) (component-operation-times c))
    2125         (get-universal-time)))
     2338  (mark-operation-done operation c))
     2339
     2340(defgeneric* around-compile-hook (component))
     2341(defgeneric* call-with-around-compile-hook (component thunk))
     2342
     2343(defmethod around-compile-hook ((c component))
     2344  (cond
     2345    ((slot-boundp c 'around-compile)
     2346     (slot-value c 'around-compile))
     2347    ((component-parent c)
     2348     (around-compile-hook (component-parent c)))))
     2349
     2350(defmethod call-with-around-compile-hook ((c component) thunk)
     2351  (let ((hook (around-compile-hook c)))
     2352    (if hook
     2353        (funcall hook thunk)
     2354        (funcall thunk))))
    21262355
    21272356(defvar *compile-op-compile-file-function* 'compile-file*
     
    21392368        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    21402369    (multiple-value-bind (output warnings-p failure-p)
    2141         (apply *compile-op-compile-file-function* source-file
    2142                :output-file output-file (compile-op-flags operation))
     2370        (call-with-around-compile-hook
     2371         c (lambda ()
     2372             (apply *compile-op-compile-file-function* source-file
     2373                    :output-file output-file (compile-op-flags operation))))
    21432374      (unless output
    21442375        (error 'compile-error :component c :operation operation))
     
    21922423(defclass load-op (basic-load-op) ())
    21932424
     2425(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
     2426  (loop
     2427    (restart-case
     2428        (return (call-next-method))
     2429      (try-recompiling ()
     2430        :report (lambda (s)
     2431                  (format s "Recompile ~a and try loading it again"
     2432                          (component-name c)))
     2433        (perform (make-sub-operation c o c 'compile-op) c)))))
     2434
    21942435(defmethod perform ((o load-op) (c cl-source-file))
    21952436  (map () #'load (input-files o c)))
    2196 
    2197 (defmethod perform-with-restarts (operation component)
    2198   ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.
    2199   (perform operation component))
    2200 
    2201 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
    2202   (declare (ignorable o))
    2203   (loop :with state = :initial
    2204     :until (or (eq state :success)
    2205                (eq state :failure)) :do
    2206     (case state
    2207       (:recompiled
    2208        (setf state :failure)
    2209        (call-next-method)
    2210        (setf state :success))
    2211       (:failed-load
    2212        (setf state :recompiled)
    2213        (perform (make-sub-operation c o c 'compile-op) c))
    2214       (t
    2215        (with-simple-restart
    2216            (try-recompiling "Recompile ~a and try loading it again"
    2217                             (component-name c))
    2218          (setf state :failed-load)
    2219          (call-next-method)
    2220          (setf state :success))))))
    2221 
    2222 (defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
    2223   (loop :with state = :initial
    2224     :until (or (eq state :success)
    2225                (eq state :failure)) :do
    2226     (case state
    2227       (:recompiled
    2228        (setf state :failure)
    2229        (call-next-method)
    2230        (setf state :success))
    2231       (:failed-compile
    2232        (setf state :recompiled)
    2233        (perform-with-restarts o c))
    2234       (t
    2235        (with-simple-restart
    2236            (try-recompiling "Try recompiling ~a"
    2237                             (component-name c))
    2238          (setf state :failed-compile)
    2239          (call-next-method)
    2240          (setf state :success))))))
    22412437
    22422438(defmethod perform ((operation load-op) (c static-file))
     
    22812477  (let ((source (component-pathname c)))
    22822478    (setf (component-property c 'last-loaded-as-source)
    2283           (and (load source)
     2479          (and (call-with-around-compile-hook c (lambda () (load source)))
    22842480               (get-universal-time)))))
    22852481
     
    23722568    (with-compilation-unit ()
    23732569      (loop :for (op . component) :in steps :do
    2374         (loop
    2375           (restart-case
    2376               (progn
    2377                 (perform-with-restarts op component)
    2378                 (return))
    2379             (retry ()
    2380               :report
    2381               (lambda (s)
    2382                 (format s (compatfmt "~@<Retry ~A.~@:>")
    2383                         (operation-description op component))))
    2384             (accept ()
    2385               :report
    2386               (lambda (s)
    2387                 (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
    2388                         (operation-description op component)))
    2389               (setf (gethash (type-of op)
    2390                              (component-operation-times component))
    2391                     (get-universal-time))
    2392               (return))))))))
     2570        (perform-with-restarts op component)))))
    23932571
    23942572(defmethod operate (operation-class system &rest args
     
    26232801                          depends-on serial in-order-to)
    26242802                        rest))
    2625            (ret
    2626             (or (find-component parent name)
    2627                 (make-instance (class-for-type parent type)))))
     2803           (ret (find-component parent name)))
    26282804      (when weakly-depends-on
    26292805        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
    26302806      (when *serial-depends-on*
    26312807        (push *serial-depends-on* depends-on))
    2632       (apply 'reinitialize-instance ret
    2633              :name (coerce-name name)
    2634              :pathname pathname
    2635              :parent parent
    2636              other-args)
     2808      (if ret
     2809          (apply 'reinitialize-instance ret
     2810                 :name (coerce-name name)
     2811                 :pathname pathname
     2812                 :parent parent
     2813                 other-args)
     2814          (setf ret
     2815                (apply 'make-instance (class-for-type parent type)
     2816                       :name (coerce-name name)
     2817                       :pathname pathname
     2818                       :parent parent
     2819                       other-args)))
    26372820      (component-pathname ret) ; eagerly compute the absolute pathname
    26382821      (when (typep ret 'module)
     
    26612844            (union-of-dependencies
    26622845             do-first
    2663        `((compile-op (load-op ,@depends-on)))))
     2846             `((compile-op (load-op ,@depends-on)))))
    26642847
    26652848      (%refresh-component-inline-methods ret rest)
     
    27072890;;;; If the docstring is ambiguous, send a bug report.
    27082891;;;;
     2892;;;; WARNING! The function below is mostly dysfunctional.
     2893;;;; For instance, it will probably run fine on most implementations on Unix,
     2894;;;; which will hopefully use the shell /bin/sh (which we force in some cases)
     2895;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
     2896;;;; But behavior on Windows may vary wildly between implementations,
     2897;;;; either relying on your having installed a POSIX sh, or going through
     2898;;;; the CMD.EXE interpreter, for a totally different meaning, depending on
     2899;;;; what is easily expressible in said implementation.
     2900;;;;
    27092901;;;; We probably should move this functionality to its own system and deprecate
    27102902;;;; use of it from the asdf package. However, this would break unspecified
     
    27122904;;;; it, and even after it's been deprecated, we will support it for a few
    27132905;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
     2906;;;;
     2907;;;; As a suggested replacement which is portable to all ASDF-supported
     2908;;;; implementations and operating systems except Genera, I recommend
     2909;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its
     2910;;;; derivatives such as xcvb-driver:run-program/for-side-effects.
    27142911
    27152912(defun* run-shell-command (control-string &rest args)
     
    27272924    (multiple-value-bind (stdout stderr exit-code)
    27282925        (excl.osi:command-output
    2729          (format nil "~a -c \"~a\""
    2730                  #+mswindows "sh" #-mswindows "/bin/sh" command)
     2926         #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
     2927         #+mswindows command ; BEWARE!
    27312928         :input nil :whole nil
    27322929         #+mswindows :show-window #+mswindows :hide)
    2733       (asdf-message "~{~&; ~a~%~}~%" stderr)
    2734       (asdf-message "~{~&; ~a~%~}~%" stdout)
     2930      (asdf-message "~{~&~a~%~}~%" stderr)
     2931      (asdf-message "~{~&~a~%~}~%" stdout)
    27352932      exit-code)
    27362933
    2737     #+clisp                    ;XXX not exactly *verbose-out*, I know
    2738     (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)
     2934    #+clisp
     2935    ;; CLISP returns NIL for exit status zero.
     2936    (if *verbose-out*
     2937        (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
     2938                                    command))
     2939               (outstream (ext:run-shell-command new-command :output :stream :wait t)))
     2940            (multiple-value-bind (retval out-lines)
     2941                (unwind-protect
     2942                     (parse-clisp-shell-output outstream)
     2943                  (ignore-errors (close outstream)))
     2944              (asdf-message "~{~&~a~%~}~%" out-lines)
     2945              retval))
     2946        ;; there will be no output, just grab up the exit status
     2947        (or (ext:run-shell-command command :output nil :wait t) 0))
    27392948
    27402949    #+clozure
    27412950    (nth-value 1
    27422951               (ccl:external-process-status
    2743                 (ccl:run-program "/bin/sh" (list "-c" command)
    2744                                  :input nil :output *verbose-out*
    2745                                  :wait t)))
     2952                (ccl:run-program
     2953                 (cond
     2954                   ((os-unix-p) "/bin/sh")
     2955                   ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE!
     2956                   (t (error "Unsupported OS")))
     2957                 (if (os-unix-p) (list "-c" command) '())
     2958                 :input nil :output *verbose-out* :wait t)))
    27462959
    27472960    #+(or cmu scl)
     
    27492962     (ext:run-program
    27502963      "/bin/sh"
    2751       (list  "-c" command)
     2964      (list "-c" command)
    27522965      :input nil :output *verbose-out*))
    27532966
    27542967    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    2755     (si:system command)
     2968    (ext:system command)
    27562969
    27572970    #+gcl
     
    27592972
    27602973    #+lispworks
    2761     (system:call-system-showing-output
    2762      command
    2763      :shell-type "/bin/sh"
    2764      :show-cmd nil
    2765      :prefix ""
    2766      :output-stream *verbose-out*)
     2974    (apply 'system:call-system-showing-output command
     2975           :show-cmd nil :prefix "" :output-stream *verbose-out*
     2976           (when (os-unix-p) '(:shell-type "/bin/sh")))
    27672977
    27682978    #+mcl
     
    27822992    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
    27832993    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
     2994
     2995#+clisp
     2996(defun* parse-clisp-shell-output (stream)
     2997  "Helper function for running shell commands under clisp.  Parses a specially-
     2998crafted output string to recover the exit status of the shell command and a
     2999list of lines of output."
     3000  (loop :with status-prefix = "ASDF-EXIT-STATUS "
     3001    :with prefix-length = (length status-prefix)
     3002    :with exit-status = -1 :with lines = ()
     3003    :for line = (read-line stream nil nil)
     3004    :while line :do (push line lines) :finally
     3005    (let* ((last (car lines))
     3006           (status (and last (>= (length last) prefix-length)
     3007                        (string-equal last status-prefix :end1 prefix-length)
     3008                        (parse-integer last :start prefix-length :junk-allowed t))))
     3009      (when status
     3010        (setf exit-status status)
     3011        (pop lines) (when (equal "" (car lines)) (pop lines)))
     3012      (return (values exit-status (reverse lines))))))
    27843013
    27853014;;;; ---------------------------------------------------------------------------
     
    27993028  (system-source-file x))
    28003029
     3030(defmethod system-source-file ((system system))
     3031  (%system-source-file system))
    28013032(defmethod system-source-file ((system-name string))
    2802   (system-source-file (find-system system-name)))
     3033  (%system-source-file (find-system system-name)))
    28033034(defmethod system-source-file ((system-name symbol))
    2804   (system-source-file (find-system system-name)))
     3035  (%system-source-file (find-system system-name)))
    28053036
    28063037(defun* system-source-directory (system-designator)
     
    28673098(defparameter *lisp-version-string*
    28683099  (let ((s (lisp-implementation-version)))
    2869     (or
    2870      #+allegro
    2871      (format nil "~A~A~@[~A~]"
    2872        excl::*common-lisp-version-number*
    2873        ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
    2874        (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
    2875        ;; Note if not using International ACL
    2876        ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
    2877        (excl:ics-target-case (:-ics "8")))
    2878      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2879      #+clisp
    2880      (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
    2881      #+clozure
    2882      (format nil "~d.~d-f~d" ; shorten for windows
    2883        ccl::*openmcl-major-version*
    2884        ccl::*openmcl-minor-version*
    2885        (logand ccl::fasl-version #xFF))
    2886      #+cmu (substitute #\- #\/ s)
    2887      #+ecl (format nil "~A~@[-~A~]" s
    2888        (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    2889          (subseq vcs-id 0 (min (length vcs-id) 8))))
    2890      #+gcl (subseq s (1+ (position #\space s)))
    2891      #+genera
    2892      (multiple-value-bind (major minor) (sct:get-system-version "System")
    2893        (format nil "~D.~D" major minor))
    2894      #+mcl (subseq s 8) ; strip the leading "Version "
    2895      s)))
     3100    (car
     3101     (list
     3102      #+allegro
     3103      (format nil "~A~A~@[~A~]"
     3104              excl::*common-lisp-version-number*
     3105              ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
     3106              (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
     3107              ;; Note if not using International ACL
     3108              ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     3109              (excl:ics-target-case (:-ics "8")))
     3110      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
     3111      #+clisp
     3112      (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
     3113      #+clozure
     3114      (format nil "~d.~d-f~d" ; shorten for windows
     3115              ccl::*openmcl-major-version*
     3116              ccl::*openmcl-minor-version*
     3117              (logand ccl::fasl-version #xFF))
     3118      #+cmu (substitute #\- #\/ s)
     3119      #+ecl (format nil "~A~@[-~A~]" s
     3120                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     3121                      (subseq vcs-id 0 (min (length vcs-id) 8))))
     3122      #+gcl (subseq s (1+ (position #\space s)))
     3123      #+genera
     3124      (multiple-value-bind (major minor) (sct:get-system-version "System")
     3125        (format nil "~D.~D" major minor))
     3126      #+mcl (subseq s 8) ; strip the leading "Version "
     3127      s))))
    28963128
    28973129(defun* implementation-type ()
     
    29023134   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
    29033135   (format nil "~(~a~@{~@[-~a~]~}~)"
    2904      (or *implementation-type* (lisp-implementation-type))
     3136           (or *implementation-type* (lisp-implementation-type))
    29053137           (or *lisp-version-string* (lisp-implementation-version))
    29063138           (or *operating-system* (software-type))
     
    29113143;;; Generic support for configuration files
    29123144
    2913 (defparameter *inter-directory-separator*
    2914   #+asdf-unix #\:
    2915   #-asdf-unix #\;)
     3145(defun inter-directory-separator ()
     3146  (if (os-unix-p) #\: #\;))
    29163147
    29173148(defun* user-homedir ()
     
    29343165                 :for dir :in (split-string dirs :separator ":")
    29353166                 :collect (try dir "common-lisp/"))
    2936              #+asdf-windows
    2937              ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
    2938                            (getenv "LOCALAPPDATA"))
    2939                        "common-lisp/config/")
    2940                  ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    2941                  ,(try (or #+lispworks (sys:get-folder-path :appdata)
    2942                            (getenv "APPDATA"))
    2943                            "common-lisp/config/"))
     3167             ,@(when (os-windows-p)
     3168                 `(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
     3169                             (getenv "LOCALAPPDATA"))
     3170                         "common-lisp/config/")
     3171                    ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
     3172                   ,(try (or #+lispworks (sys:get-folder-path :appdata)
     3173                             (getenv "APPDATA"))
     3174                         "common-lisp/config/")))
    29443175             ,(try (user-homedir) ".config/common-lisp/")))))
    29453176    (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
    29463177(defun* system-configuration-directories ()
    2947   (remove-if
    2948    #'null
    2949    `(#+asdf-windows
    2950      ,(flet ((try (x sub) (try-directory-subpath x sub)))
     3178  (cond
     3179    ((os-unix-p) '(#p"/etc/common-lisp/"))
     3180    ((os-windows-p)
     3181     (aif
     3182      (flet ((try (x sub) (try-directory-subpath x sub)))
    29513183        ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    29523184        (try (or #+lispworks (sys:get-folder-path :common-appdata)
     
    29543186                 (try (getenv "ALLUSERSPROFILE") "Application Data/"))
    29553187             "common-lisp/config/"))
    2956      #+asdf-unix #p"/etc/common-lisp/")))
     3188      (list it)))))
    29573189
    29583190(defun* in-first-directory (dirs x)
     
    30733305    (or
    30743306     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
    3075      #+asdf-windows
    3076      (try (or #+lispworks (sys:get-folder-path :local-appdata)
    3077               (getenv "LOCALAPPDATA")
    3078               #+lispworks (sys:get-folder-path :appdata)
    3079               (getenv "APPDATA"))
    3080           "common-lisp" "cache" :implementation)
     3307     (when (os-windows-p)
     3308       (try (or #+lispworks (sys:get-folder-path :local-appdata)
     3309                (getenv "LOCALAPPDATA")
     3310                #+lispworks (sys:get-folder-path :appdata)
     3311                (getenv "APPDATA"))
     3312            "common-lisp" "cache" :implementation))
    30813313     '(:home ".cache" "common-lisp" :implementation))))
    30823314
     
    32053437           (typep c '(or string pathname
    32063438                      (member :default-directory :*/ :**/ :*.*.*
    3207                         :implementation :implementation-type
    3208                         #+asdf-unix :uid)))))
     3439                        :implementation :implementation-type)))))
    32093440    (or (typep x 'boolean)
    32103441        (absolute-component-p x)
     
    32663497      :with end = (length string)
    32673498      :with source = nil
    3268       :for i = (or (position *inter-directory-separator* string :start start) end) :do
     3499      :with separator = (inter-directory-separator)
     3500      :for i = (or (position separator string :start start) end) :do
    32693501      (let ((s (subseq string start i)))
    32703502        (cond
     
    35783810       (t t)
    35793811       :ignore-inherited-configuration))))
    3580 
    3581 ;;;; -----------------------------------------------------------------
    3582 ;;;; Windows shortcut support.  Based on:
    3583 ;;;;
    3584 ;;;; Jesse Hager: The Windows Shortcut File Format.
    3585 ;;;; http://www.wotsit.org/list.asp?fc=13
    3586 
    3587 #+(and asdf-windows (not clisp))
    3588 (progn
    3589 (defparameter *link-initial-dword* 76)
    3590 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
    3591 
    3592 (defun* read-null-terminated-string (s)
    3593   (with-output-to-string (out)
    3594     (loop :for code = (read-byte s)
    3595       :until (zerop code)
    3596       :do (write-char (code-char code) out))))
    3597 
    3598 (defun* read-little-endian (s &optional (bytes 4))
    3599   (loop :for i :from 0 :below bytes
    3600     :sum (ash (read-byte s) (* 8 i))))
    3601 
    3602 (defun* parse-file-location-info (s)
    3603   (let ((start (file-position s))
    3604         (total-length (read-little-endian s))
    3605         (end-of-header (read-little-endian s))
    3606         (fli-flags (read-little-endian s))
    3607         (local-volume-offset (read-little-endian s))
    3608         (local-offset (read-little-endian s))
    3609         (network-volume-offset (read-little-endian s))
    3610         (remaining-offset (read-little-endian s)))
    3611     (declare (ignore total-length end-of-header local-volume-offset))
    3612     (unless (zerop fli-flags)
    3613       (cond
    3614         ((logbitp 0 fli-flags)
    3615           (file-position s (+ start local-offset)))
    3616         ((logbitp 1 fli-flags)
    3617           (file-position s (+ start
    3618                               network-volume-offset
    3619                               #x14))))
    3620       (concatenate 'string
    3621         (read-null-terminated-string s)
    3622         (progn
    3623           (file-position s (+ start remaining-offset))
    3624           (read-null-terminated-string s))))))
    3625 
    3626 (defun* parse-windows-shortcut (pathname)
    3627   (with-open-file (s pathname :element-type '(unsigned-byte 8))
    3628     (handler-case
    3629         (when (and (= (read-little-endian s) *link-initial-dword*)
    3630                    (let ((header (make-array (length *link-guid*))))
    3631                      (read-sequence header s)
    3632                      (equalp header *link-guid*)))
    3633           (let ((flags (read-little-endian s)))
    3634             (file-position s 76)        ;skip rest of header
    3635             (when (logbitp 0 flags)
    3636               ;; skip shell item id list
    3637               (let ((length (read-little-endian s 2)))
    3638                 (file-position s (+ length (file-position s)))))
    3639             (cond
    3640               ((logbitp 1 flags)
    3641                 (parse-file-location-info s))
    3642               (t
    3643                 (when (logbitp 2 flags)
    3644                   ;; skip description string
    3645                   (let ((length (read-little-endian s 2)))
    3646                     (file-position s (+ length (file-position s)))))
    3647                 (when (logbitp 3 flags)
    3648                   ;; finally, our pathname
    3649                   (let* ((length (read-little-endian s 2))
    3650                          (buffer (make-array length)))
    3651                     (read-sequence buffer s)
    3652                     (map 'string #'code-char buffer)))))))
    3653       (end-of-file ()
    3654         nil)))))
    36553812
    36563813;;;; -----------------------------------------------------------------
     
    38143971      :with start = 0
    38153972      :with end = (length string)
    3816       :for pos = (position *inter-directory-separator* string :start start) :do
     3973      :with separator = (inter-directory-separator)
     3974      :for pos = (position separator string :start start) :do
    38173975      (let ((s (subseq string start (or pos end))))
    38183976        (flet ((check (dir)
     
    38674025      (:directory ,(default-directory))
    38684026      ,@(loop :for dir :in
    3869           `(#+asdf-unix
    3870             ,@`(,(or (getenv "XDG_DATA_HOME")
    3871                      (try (user-homedir) ".local/share/"))
    3872                 ,@(split-string (or (getenv "XDG_DATA_DIRS")
    3873                                     "/usr/local/share:/usr/share")
    3874                                 :separator ":"))
    3875             #+asdf-windows
    3876             ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata)
    3877                      (getenv "LOCALAPPDATA"))
    3878                 ,(or #+lispworks (sys:get-folder-path :appdata)
    3879                      (getenv "APPDATA"))
    3880                 ,(or #+lispworks (sys:get-folder-path :common-appdata)
    3881                      (getenv "ALLUSERSAPPDATA")
    3882                      (try (getenv "ALLUSERSPROFILE") "Application Data/"))))
     4027          `(,@(when (os-unix-p)
     4028                `(,(or (getenv "XDG_DATA_HOME")
     4029                       (try (user-homedir) ".local/share/"))
     4030                  ,@(split-string (or (getenv "XDG_DATA_DIRS")
     4031                                      "/usr/local/share:/usr/share")
     4032                                  :separator ":")))
     4033            ,@(when (os-windows-p)
     4034                `(,(or #+lispworks (sys:get-folder-path :local-appdata)
     4035                       (getenv "LOCALAPPDATA"))
     4036                  ,(or #+lispworks (sys:get-folder-path :appdata)
     4037                       (getenv "APPDATA"))
     4038                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
     4039                       (getenv "ALLUSERSAPPDATA")
     4040                       (try (getenv "ALLUSERSPROFILE") "Application Data/")))))
    38834041          :collect `(:directory ,(try dir "common-lisp/systems/"))
    38844042          :collect `(:tree ,(try dir "common-lisp/source/")))
     
    40424200#+ecl
    40434201(progn
    4044   (setf *compile-op-compile-file-function*
    4045         (lambda (input-file &rest keys &key output-file &allow-other-keys)
    4046           (declare (ignore output-file))
    4047           (multiple-value-bind (object-file flags1 flags2)
    4048               (apply 'compile-file* input-file :system-p t keys)
    4049             (values (and object-file
    4050                          (c::build-fasl (compile-file-pathname object-file :type :fasl)
    4051                                         :lisp-files (list object-file))
    4052                          object-file)
    4053                     flags1
    4054                     flags2))))
     4202  (setf *compile-op-compile-file-function* 'ecl-compile-file)
     4203
     4204  (defun use-ecl-byte-compiler-p ()
     4205    (member :ecl-bytecmp *features*))
     4206
     4207  (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
     4208    (if (use-ecl-byte-compiler-p)
     4209        (apply 'compile-file* input-file keys)
     4210        (multiple-value-bind (object-file flags1 flags2)
     4211            (apply 'compile-file* input-file :system-p t keys)
     4212          (values (and object-file
     4213                       (c::build-fasl (compile-file-pathname object-file :type :fasl)
     4214                                      :lisp-files (list object-file))
     4215                       object-file)
     4216                  flags1
     4217                  flags2))))
    40554218
    40564219  (defmethod output-files ((operation compile-op) (c cl-source-file))
    40574220    (declare (ignorable operation))
    4058     (let ((p (lispize-pathname (component-pathname c))))
    4059       (list (compile-file-pathname p :type :object)
    4060             (compile-file-pathname p :type :fasl))))
     4221    (let* ((p (lispize-pathname (component-pathname c)))
     4222           (f (compile-file-pathname p :type :fasl)))
     4223      (if (use-ecl-byte-compiler-p)
     4224          (list f)
     4225          (list (compile-file-pathname p :type :object) f))))
    40614226
    40624227  (defmethod perform ((o load-op) (c cl-source-file))
     
    40644229         (loop :for i :in (input-files o c)
    40654230           :unless (string= (pathname-type i) "fas")
    4066            :collect (compile-file-pathname (lispize-pathname i))))))
     4231               :collect (compile-file-pathname (lispize-pathname i))))))
    40674232
    40684233;;;; -----------------------------------------------------------------
     
    40914256            #+clisp ,x
    40924257            #+clozure ccl:*module-provider-functions*
    4093             #+cmu ext:*module-provider-functions*
    4094             #+ecl si:*module-provider-functions*
     4258            #+(or cmu ecl) ext:*module-provider-functions*
    40954259            #+sbcl sb-ext:*module-provider-functions*))))
    40964260
Note: See TracChangeset for help on using the changeset viewer.