Changeset 13691


Ignore:
Timestamp:
11/03/11 16:04:19 (9 years ago)
Author:
Mark Evenson
Message:

Upgrade to ASDF-2.018.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r13655 r13691  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.017.22: Another System Definition Facility.
     2;;; This is ASDF 2.018: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    9191    #+(or gcl genera)
    9292    (loop :for (unsupported . replacement) :in
    93       `(("~3i~_" . "")
    94         #+genera
    95         ,@(("~@<" . "")
    96            ("; ~@;" . "; ")
    97            ("~@:>" . "")
    98            ("~:>" . ""))) :do
     93      (append
     94       '(("~3i~_" . ""))
     95       #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
    9996      (loop :for found = (search unsupported format) :while found :do
    10097        (setf format
     
    111108         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    112109         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    113          (asdf-version "2.017.22")
     110         (asdf-version "2.018")
    114111         (existing-asdf (find-class 'component nil))
    115112         (existing-version *asdf-version*)
     
    352349            #:merge-pathnames*
    353350            #:coerce-pathname
     351            #:subpathname
    354352            #:pathname-directory-pathname
    355353            #:read-file-forms
     
    14181416;;;; http://www.wotsit.org/list.asp?fc=13
    14191417
    1420 #-clisp
     1418#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
    14211419(progn
    14221420(defparameter *link-initial-dword* 76)
     
    15711569    ((atom x)
    15721570     (and (member x features) t))
    1573     ((eq 'not (car x))
     1571    ((eq :not (car x))
    15741572     (assert (null (cddr x)))
    15751573     (not (featurep (cadr x) features)))
    1576     ((eq 'or (car x))
     1574    ((eq :or (car x))
    15771575     (some #'(lambda (x) (featurep x features)) (cdr x)))
    1578     ((eq 'and (car x))
     1576    ((eq :and (car x))
    15791577     (every #'(lambda (x) (featurep x features)) (cdr x)))
    15801578    (t
     
    15821580
    15831581(defun* os-unix-p ()
    1584   (featurep '(or :unix :cygwin :darwin)))
     1582  (featurep '(:or :unix :cygwin :darwin)))
    15851583
    15861584(defun* os-windows-p ()
    1587   (and (not (os-unix-p)) (featurep '(or :win32 :windows :mswindows :mingw32))))
     1585  (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
    15881586
    15891587(defun* probe-asd (name defaults)
     
    15951593        (when (probe-file* file)
    15961594          (return file)))
    1597       #-clisp
     1595      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
    15981596      (when (os-windows-p)
    15991597        (let ((shortcut
     
    18711869   :type (source-file-type component (component-system component))
    18721870   :defaults (component-parent-pathname component)))
     1871
     1872(defun* subpathname (pathname subpath &key type)
     1873  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
     1874                                  (pathname-directory-pathname pathname))))
     1875
     1876(defun* try-subpathname (pathname subpath &key type)
     1877  (let* ((sp (and pathname (probe-file* pathname)
     1878                  (subpathname pathname subpath :type type)))
     1879         (ts (and sp (probe-file* sp))))
     1880    (and ts (values sp ts))))
     1881
    18731882
    18741883;;;; -------------------------------------------------------------------------
     
    22062215                                (update-flag
    22072216                                 (do-traverse operation kid #'internal-collect))
     2217                              #-genera
    22082218                              (missing-dependency (condition)
    22092219                                (when (eq (module-if-component-dep-fails c)
     
    23692379    (multiple-value-bind (output warnings-p failure-p)
    23702380        (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))))
     2381         c #'(lambda ()
     2382               (apply *compile-op-compile-file-function* source-file
     2383                      :output-file output-file (compile-op-flags operation))))
    23742384      (unless output
    23752385        (error 'compile-error :component c :operation operation))
     
    24772487  (let ((source (component-pathname c)))
    24782488    (setf (component-property c 'last-loaded-as-source)
    2479           (and (call-with-around-compile-hook c (lambda () (load source)))
     2489          (and (call-with-around-compile-hook c #'(lambda () (load source)))
    24802490               (get-universal-time)))))
    24812491
     
    26592669  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
    26602670
    2661 (defun* determine-system-pathname (pathname pathname-supplied-p)
     2671(defun* determine-system-pathname (pathname)
    26622672  ;; The defsystem macro calls us to determine
    26632673  ;; the pathname of a system as follows:
     
    26672677  (let* ((file-pathname (load-pathname))
    26682678         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
    2669     (or (and pathname-supplied-p
    2670              (merge-pathnames* (coerce-pathname pathname :type :directory)
    2671                                directory-pathname))
     2679    (or (and pathname (subpathname directory-pathname pathname :type :directory))
    26722680        directory-pathname
    26732681        (default-directory))))
     
    28502858
    28512859(defun* do-defsystem (name &rest options
    2852                            &key (pathname nil pathname-arg-p) (class 'system)
     2860                           &key pathname (class 'system)
    28532861                           defsystem-depends-on &allow-other-keys)
    28542862  ;; The system must be registered before we parse the body,
     
    28772885       nil (list*
    28782886            :module name
    2879             :pathname (determine-system-pathname pathname pathname-arg-p)
     2887            :pathname (determine-system-pathname pathname)
    28802888            component-options)))))
    28812889
     
    30573065
    30583066(defun* system-relative-pathname (system name &key type)
    3059   (merge-pathnames*
    3060    (coerce-pathname name :type type)
    3061    (system-source-directory system)))
     3067  (subpathname (system-source-directory system) name :type type))
    30623068
    30633069
     
    30673073;;; produce a string to identify current implementation.
    30683074;;; Initially stolen from SLIME's SWANK, rewritten since.
    3069 ;;; The (car '(...)) idiom avoids unreachable code warnings.
    3070 
    3071 (defparameter *implementation-type*
    3072   (car '(#+abcl :abcl #+allegro :acl
    3073          #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu
    3074          #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl
    3075          #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl)))
    3076 
    3077 (defparameter *operating-system*
    3078   (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win
    3079          #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd.
    3080          #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd
    3081          #+(or solaris sunos) :solaris
    3082          #+(or freebsd netbsd openbsd bsd) :bsd
    3083          #+unix :unix
    3084          #+genera :genera)))
    3085 
    3086 (defparameter *architecture*
    3087   (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64
    3088          #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86
    3089          #+hppa64 :hppa64 #+hppa :hppa
    3090          #+(or ppc64 ppc64-target) :ppc64
    3091          #+(or ppc32 ppc32-target ppc powerpc) :ppc32
    3092          #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32
    3093          #+(or arm arm-target) :arm
    3094          #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java
    3095          #+mipsel :mispel #+mipseb :mipseb #+mips :mips
    3096          #+alpha :alpha #+imach :imach)))
    3097 
    3098 (defparameter *lisp-version-string*
     3075;;; We're back to runtime checking, for the sake of e.g. ABCL.
     3076
     3077(defun* first-feature (features)
     3078  (dolist (x features)
     3079    (multiple-value-bind (val feature)
     3080        (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
     3081      (when (featurep feature) (return val)))))
     3082
     3083(defun implementation-type ()
     3084  (first-feature
     3085   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
     3086     :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl)))
     3087
     3088(defun operating-system ()
     3089  (first-feature
     3090   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
     3091     (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
     3092     (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
     3093     (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
     3094     :genera)))
     3095
     3096(defun architecture ()
     3097  (first-feature
     3098   '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
     3099     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
     3100     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
     3101     :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
     3102     :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
     3103     ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
     3104     ;; we may have to segregate the code still by architecture.
     3105     (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
     3106
     3107(defun lisp-version-string ()
    30993108  (let ((s (lisp-implementation-version)))
    3100     (car
     3109    (car ; as opposed to OR, this idiom prevents some unreachable code warning
    31013110     (list
    31023111      #+allegro
     
    31173126              (logand ccl::fasl-version #xFF))
    31183127      #+cmu (substitute #\- #\/ s)
     3128      #+scl (format nil "~A~A" s
     3129        ;; ANSI upper case vs lower case.
     3130        (ecase ext:*case-mode* (:upper "") (:lower "l")))
    31193131      #+ecl (format nil "~A~@[-~A~]" s
    31203132                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     
    31273139      s))))
    31283140
    3129 (defun* implementation-type ()
    3130   *implementation-type*)
    3131 
    31323141(defun* implementation-identifier ()
    31333142  (substitute-if
    31343143   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
    31353144   (format nil "~(~a~@{~@[-~a~]~}~)"
    3136            (or *implementation-type* (lisp-implementation-type))
    3137            (or *lisp-version-string* (lisp-implementation-version))
    3138            (or *operating-system* (software-type))
    3139            (or *architecture* (machine-type)))))
     3145           (or (implementation-type) (lisp-implementation-type))
     3146           (or (lisp-version-string) (lisp-implementation-version))
     3147           (or (operating-system) (software-type))
     3148           (or (architecture) (machine-type)))))
    31403149
    31413150
     
    31523161    #-mcl (user-homedir-pathname))))
    31533162
    3154 (defun* try-directory-subpath (x sub &key type)
    3155   (let* ((p (and x (ensure-directory-pathname x)))
    3156          (tp (and p (probe-file* p)))
    3157          (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
    3158          (ts (and sp (probe-file* sp))))
    3159     (and ts (values sp ts))))
    31603163(defun* user-configuration-directories ()
    31613164  (let ((dirs
    3162          (flet ((try (x sub) (try-directory-subpath x sub)))
    3163            `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
    3164              ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
    3165                  :for dir :in (split-string dirs :separator ":")
    3166                  :collect (try dir "common-lisp/"))
    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/")))
    3175              ,(try (user-homedir) ".config/common-lisp/")))))
     3165         `(,(try-subpathname (getenv "XDG_CONFIG_HOME") "common-lisp/")
     3166           ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
     3167               :for dir :in (split-string dirs :separator ":")
     3168               :collect (try-subpathname dir "common-lisp/"))
     3169           ,@(when (os-windows-p)
     3170               `(,(try-subpathname (or #+lispworks (sys:get-folder-path :local-appdata)
     3171                                       (getenv "LOCALAPPDATA"))
     3172                                   "common-lisp/config/")
     3173                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
     3174                 ,(try-subpathname (or #+lispworks (sys:get-folder-path :appdata)
     3175                                       (getenv "APPDATA"))
     3176                                   "common-lisp/config/")))
     3177           ,(try-subpathname (user-homedir) ".config/common-lisp/"))))
    31763178    (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
     3179
    31773180(defun* system-configuration-directories ()
    31783181  (cond
     
    31803183    ((os-windows-p)
    31813184     (aif
    3182       (flet ((try (x sub) (try-directory-subpath x sub)))
    3183         ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    3184         (try (or #+lispworks (sys:get-folder-path :common-appdata)
    3185                  (getenv "ALLUSERSAPPDATA")
    3186                  (try (getenv "ALLUSERSPROFILE") "Application Data/"))
    3187              "common-lisp/config/"))
     3185      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
     3186      (try-subpathname (or #+lispworks (sys:get-folder-path :common-appdata)
     3187                           (getenv "ALLUSERSAPPDATA")
     3188                           (subpathname (getenv "ALLUSERSPROFILE") "Application Data/"))
     3189                       "common-lisp/config/")
    31883190      (list it)))))
    31893191
     
    37003702(defmethod output-files :around (operation component)
    37013703  "Translate output files, unless asked not to"
    3702   (declare (ignorable operation component))
     3704  operation component ;; hush genera, not convinced by declare ignorable(!)
    37033705  (values
    37043706   (multiple-value-bind (files fixedp) (call-next-method)
     
    37843786     (centralize-lisp-binaries nil)
    37853787     (default-toplevel-directory
    3786          ;; Use ".cache/common-lisp" instead ???
    3787          (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
    3788                            (user-homedir)))
     3788         (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
    37893789     (include-per-user-information nil)
    37903790     (map-all-source-files (or #+(or ecl clisp) t nil))
     
    40184018    #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
    40194019    :inherit-configuration
    4020     #+cmu (:tree #p"modules:")))
     4020    #+cmu (:tree #p"modules:")
     4021    #+scl (:tree #p"file://modules/")))
    40214022(defun* default-source-registry ()
    4022   (flet ((try (x sub) (try-directory-subpath x sub)))
    4023     `(:source-registry
    4024       #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
    4025       (:directory ,(default-directory))
     4023  `(:source-registry
     4024    #+sbcl (:directory ,(try-subpathname (user-homedir) ".sbcl/systems/"))
     4025    (:directory ,(default-directory))
    40264026      ,@(loop :for dir :in
    40274027          `(,@(when (os-unix-p)
    40284028                `(,(or (getenv "XDG_DATA_HOME")
    4029                        (try (user-homedir) ".local/share/"))
     4029                       (try-subpathname (user-homedir) ".local/share/"))
    40304030                  ,@(split-string (or (getenv "XDG_DATA_DIRS")
    40314031                                      "/usr/local/share:/usr/share")
     
    40384038                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
    40394039                       (getenv "ALLUSERSAPPDATA")
    4040                        (try (getenv "ALLUSERSPROFILE") "Application Data/")))))
    4041           :collect `(:directory ,(try dir "common-lisp/systems/"))
    4042           :collect `(:tree ,(try dir "common-lisp/source/")))
    4043       :inherit-configuration)))
     4040                       (try-subpathname (getenv "ALLUSERSPROFILE") "Application Data/")))))
     4041          :collect `(:directory ,(try-subpathname dir "common-lisp/systems/"))
     4042          :collect `(:tree ,(try-subpathname dir "common-lisp/source/")))
     4043      :inherit-configuration))
    40444044(defun* user-source-registry ()
    40454045  (in-user-configuration-directory *source-registry-file*))
     
    42394239  (handler-bind
    42404240      ((style-warning #'muffle-warning)
     4241       #-genera
    42414242       (missing-component (constantly nil))
    42424243       (error #'(lambda (e)
Note: See TracChangeset for help on using the changeset viewer.