Commit 30bb39c6 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

1.715: support gcl 2.7.0

parent 95c5ffb8
Loading
Loading
Loading
Loading
+1 −0
Original line number Diff line number Diff line
@@ -35,3 +35,4 @@ tmp/
*.a
*.*fsl
*.bak
*.data
+304 −274
Original line number Diff line number Diff line
@@ -49,7 +49,8 @@

(cl:in-package :cl-user)

(declaim (optimize (speed 2) (debug 2) (safety 3)))
(declaim (optimize (speed 2) (debug 2) (safety 3))
         #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))

#+ecl (require :cmp)

@@ -57,35 +58,40 @@
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;; See more at the end of the file.

#+gcl
(eval-when (:compile-toplevel :load-toplevel)
  (defpackage :asdf-utilities (:use :cl))
  (defpackage :asdf (:use :cl :asdf-utilities)))

(eval-when (:load-toplevel :compile-toplevel :execute)
  #+allegro
  (setf excl::*autoload-package-name-alist*
        (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car))
        (remove "asdf" excl::*autoload-package-name-alist*
                :test 'equalp :key 'car))
  (let* ((asdf-version
          ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
          (subseq "VERSION:1.714" (1+ (length "VERSION"))))
          ;; the 1+ helps the version bumping script discriminate
          (subseq "VERSION:1.715" (1+ (length "VERSION"))))
         (existing-asdf (find-package :asdf))
         (versym '#:*asdf-version*)
         (existing-version (and existing-asdf
                                (symbol-value
                                 (find-symbol (string versym) existing-asdf))))
         (redefined-functions
          '(#:perform #:explain #:output-files #:operation-done-p
            #:perform-with-restarts #:component-relative-pathname
            #:system-source-file #:operate #:find-component))
         (vername '#:*asdf-version*)
         (versym (and existing-asdf
                      (find-symbol (string vername) existing-asdf)))
         (existing-version (and versym (boundp versym) (symbol-value versym)))
         (already-there (equal asdf-version existing-version)))
    (unless (and existing-asdf already-there)
      #-gcl
      (when existing-asdf
        (format *error-output*
                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
                existing-version asdf-version))
      (labels ((rename-away (package)
      (labels
          ((rename-away (package)
             (loop :with name = (package-name package)
               :for i :from 1 :for new = (format nil "~A.~D" name i)
               :unless (find-package new) :do
               (rename-package-name package name new)))
           (rename-package-name (package old new)
                 (let* ((old-names (cons (package-name package) (package-nicknames package)))
             (let* ((old-names (cons (package-name package)
                                     (package-nicknames package)))
                    (new-names (subst new old old-names :test 'equal))
                    (new-name (car new-names))
                    (new-nicknames (cdr new-names)))
@@ -99,8 +105,10 @@
                      :from-end t)))
               (cond
                 (previous
                      (map () #'rename-away (cdr previous)) ;; packages with conflicting (nick)names
                      (let ((p (car previous))) ;; previous package with same name
                  ;; do away with packages with conflicting (nick)names
                  (map () #'rename-away (cdr previous))
                  ;; reuse previous package with same name
                  (let ((p (car previous)))
                    (rename-package p name nicknames)
                    (ensure-use p use)
                    p))
@@ -144,13 +152,23 @@
               (ensure-export p export)
               (ensure-fmakunbound p fmakunbound)
               p)))
        (ensure-package
         ':asdf-utilities
         :nicknames '(#:asdf-extensions)
         :use '(#:common-lisp)
         :unintern '(#:split #:make-collector)
        (macrolet
            ((pkgdcl (name &key nicknames use export
                           redefined-functions unintern fmakunbound shadow)
               `(ensure-package
                 ',name :nicknames ',nicknames :use ',use :export ',export
                 :shadow ',shadow
                 :unintern ',(append #-(or gcl ecl) redefined-functions
                                     unintern)
                 :fmakunbound ',(append #+(or gcl ecl) redefined-functions
                                        fmakunbound))))
          (pkgdcl
           :asdf-utilities
           :nicknames (#:asdf-extensions)
           :use (#:common-lisp)
           :unintern (#:split #:make-collector)
           :export
         '(#:absolute-pathname-p
           (#:absolute-pathname-p
            #:aif
            #:appendf
            #:asdf-message
@@ -163,7 +181,6 @@
            #:length=n-p
            #:merge-pathnames*
            #:pathname-directory-pathname
           #:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname
            #:read-file-forms
            #:remove-keys
            #:remove-keyword
@@ -174,19 +191,23 @@
            #:system-registered-p
            #:truenamize
            #:while-collecting))
        (ensure-package
         ':asdf
         :use '(:common-lisp :asdf-utilities)
         :unintern `(#-(or gcl ecl) ,@redefined-functions
                           #:*asdf-revision* #:around #:asdf-method-combination
          (pkgdcl
           :asdf
           :use (:common-lisp :asdf-utilities)
           :redefined-functions
           (#:perform #:explain #:output-files #:operation-done-p
            #:perform-with-restarts #:component-relative-pathname
            #:system-source-file #:operate #:find-component)
           :unintern
           (#:*asdf-revision* #:around #:asdf-method-combination
            #:split #:make-collector)
         :fmakunbound `(#+(or gcl ecl) ,@redefined-functions
                              #:system-source-file
           :fmakunbound
           (#:system-source-file
            #:component-relative-pathname #:system-relative-pathname
            #:process-source-registry
            #:inherit-source-registry #:process-source-registry-directive)
           :export
         '(#:defsystem #:oos #:operate #:find-system #:run-shell-command
           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
            #:system-definition-pathname #:find-component ; miscellaneous
            #:compile-system #:load-system #:test-system
            #:compile-op #:load-op #:load-source-op
@@ -235,7 +256,7 @@

            #:operation-on-warnings
            #:operation-on-failure
                                        ;#:*component-parent-pathname*
            ;;#:*component-parent-pathname*
            #:*system-definition-search-functions*
            #:*central-registry*         ; variables
            #:*compile-file-warnings-behaviour*
@@ -277,8 +298,8 @@
            #:compute-source-registry
            #:clear-source-registry
            #:ensure-source-registry
           #:process-source-registry))
        (let* ((version (intern* versym :asdf))
            #:process-source-registry)))
        (let* ((version (intern* vername :asdf))
               (upvar (intern* '#:*upgraded-p* :asdf))
               (upval0 (and (boundp upvar) (symbol-value upvar)))
               (upval1 (if existing-version (cons existing-version upval0) upval0)))
@@ -289,6 +310,10 @@
(in-package :asdf)

;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
#+gcl
(eval-when (:compile-toplevel :load-toplevel)
  (defvar *asdf-version* nil)
  (defvar *upgraded-p* nil))
(when *upgraded-p*
   #+ecl
   (defmethod update-instance-for-redefined-class :after
@@ -449,14 +474,6 @@ processed in order by `operate`."))
(defmacro aif (test then &optional else)
  `(let ((it ,test)) (if it ,then ,else)))

(defun pathname-sans-name+type (pathname)
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME and TYPE components.
Issue: doesn't override the VERSION component.

Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead."
  (make-pathname :name nil :type nil :defaults pathname))

(defun pathname-directory-pathname (pathname)
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
@@ -498,6 +515,13 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
             (values (pathname-host defaults)
                     (pathname-device defaults)
                     (append (pathname-directory defaults) (cdr directory))
                     (unspecific-handler defaults)))
            #+gcl
            (t
             (assert (stringp (first directory)))
             (values (pathname-host defaults)
                     (pathname-device defaults)
                     (append (pathname-directory defaults) directory)
                     (unspecific-handler defaults))))
        (make-pathname :host host :device device :directory directory
                       :name (funcall unspecific-handler name)
@@ -539,7 +563,7 @@ starting the separation from the end, e.g. when called with arguments
         ;; 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 sbcl ccl ecl lispworks) :unspecific)))
         (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
    (destructuring-bind (name &optional (type unspecific))
        (split-string filename :max 2 :separator ".")
      (if (equal name "")
@@ -711,6 +735,15 @@ actually-existing directory."
        (return p))
      (let ((sofar (ignore-errors (truename (pathname-root p)))))
        (unless sofar (return p))
        (flet ((solution (directory)
                 (merge-pathnames*
                  (make-pathname :host nil :device nil
                                 :directory directory
                                 :name (pathname-name p)
                                 :type (pathname-type p)
                                 :version (pathname-version p)
                                 :defaults "/" :case :local)
                  sofar)))
          (loop :for component :in (cdr directory)
            :for rest :on (cdr directory)
            :for more = (ignore-errors
@@ -720,19 +753,9 @@ actually-existing directory."
                            sofar))) :do
            (if more
                (setf sofar more)
              (return
                (merge-pathnames*
                 (make-pathname :host nil :device nil
                                :directory `(:relative ,@rest)
                                :defaults p)
                 sofar)))
                (return (solution `(:relative ,@rest))))
            :finally
          (return
            (merge-pathnames*
             (make-pathname :host nil :device nil
                            :directory nil
                            :defaults p)
             sofar)))))))
            (return (solution nil))))))))

(defun lispize-pathname (input-file)
  (make-pathname :type "lisp" :defaults input-file))
@@ -2021,7 +2044,7 @@ Returns the new tree (which probably shares structure with the old one)"

(defun sysdef-error-component (msg type name value)
  (sysdef-error (concatenate 'string msg
                             "~&The value specified for ~(~A~) ~A is ~W")
                             "~&The value specified for ~(~A~) ~A is ~S")
                type name value))

(defun check-component-input (type name weakly-depends-on
@@ -2157,20 +2180,9 @@ synchronously execute the result using a Bourne-compatible shell, with
output to `*verbose-out*`.  Returns the shell's exit code."
  (let ((command (apply #'format nil control-string args)))
    (asdf-message "; $ ~A~%" command)
    #+sbcl
    (sb-ext:process-exit-code
     (apply #'sb-ext:run-program
            #+win32 "sh" #-win32 "/bin/sh"
            (list  "-c" command)
            :input nil :output *verbose-out*
            #+win32 '(:search t) #-win32 nil))

    #+(or cmu scl)
    (ext:process-exit-code
     (ext:run-program
      "/bin/sh"
      (list  "-c" command)
      :input nil :output *verbose-out*))
    #+abcl
    (ext:run-shell-command command :output *verbose-out*)

    #+allegro
    ;; will this fail if command has embedded quotes - it seems to work
@@ -2184,18 +2196,10 @@ output to `*verbose-out*`. Returns the shell's exit code."
      (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
      exit-code)

    #+lispworks
    (system:call-system-showing-output
     command
     :shell-type "/bin/sh"
     :show-cmd nil
     :prefix ""
     :output-stream *verbose-out*)

    #+clisp                     ;XXX not exactly *verbose-out*, I know
    (ext:run-shell-command  command :output :terminal :wait t)

    #+openmcl
    #+clozure
    (nth-value 1
               (ccl:external-process-status
                (ccl:run-program "/bin/sh" (list "-c" command)
@@ -2205,12 +2209,34 @@ output to `*verbose-out*`. Returns the shell's exit code."
    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    (si:system command)

    #+abcl
    (ext:run-shell-command command :output *verbose-out*)
    #+gcl
    (lisp:system command)

    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl abcl)
    (error "RUN-SHELL-COMMAND not implemented for this Lisp")
    ))
    #+lispworks
    (system:call-system-showing-output
     command
     :shell-type "/bin/sh"
     :show-cmd nil
     :prefix ""
     :output-stream *verbose-out*)

    #+sbcl
    (sb-ext:process-exit-code
     (apply #'sb-ext:run-program
            #+win32 "sh" #-win32 "/bin/sh"
            (list  "-c" command)
            :input nil :output *verbose-out*
            #+win32 '(:search t) #-win32 nil))

    #+(or cmu scl)
    (ext:process-exit-code
     (ext:run-program
      "/bin/sh"
      (list  "-c" command)
      :input nil :output *verbose-out*))

    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))

;;;; ---------------------------------------------------------------------------
;;;; system-relative-pathname
@@ -2229,9 +2255,13 @@ located."
                 :defaults (system-source-file system-designator)))

(defun relativize-directory (directory)
  (if (eq (car directory) :absolute)
      (cons :relative (cdr directory))
      directory))
  (cond
    ((stringp directory)
     (list :relative directory))
    ((eq (car directory) :absolute)
     (cons :relative (cdr directory)))
    (t
     directory)))

(defun relativize-pathname-directory (pathspec)
  (let ((p (pathname pathspec)))
+4 −4
Original line number Diff line number Diff line
@@ -185,11 +185,11 @@
                      (handler-bind
                        ((error (lambda (c)
                                  (incf system-failures)
                                  (format *error-output* "~&error! ~a~%sysdef:~% ~W~%" c system-definition)
                                  (format *error-output* "~&error! ~a~%sysdef:~% ~S~%" c system-definition)
                                  #+sbcl (sb-debug:backtrace 69)
                                  #+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
                                  #+clisp (system::print-backtrace)
                                  (format result-stream "~&~%***~%error: ~a~%~:w"
                                  (format result-stream "~&~%***~%error: ~a~%~s"
                                          c system-definition)
                                  (return-from :test-system))))
                        (unless (and (or (typep system-pathname 'logical-pathname)
@@ -241,9 +241,9 @@
                                             :missing)))
                            test-files))

            (format result-stream "~&~%~% translations: ~a: ~:w" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))
            (format result-stream "~&~%~% translations: ~a: ~s" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))

            (format result-stream "~&~%~% variations:~% systems: ~:w~% modules: ~:w~% files: ~:w"
            (format result-stream "~&~%~% variations:~% systems: ~s~% modules: ~s~% files: ~s"
                    systems modules files)

            (let ((homogeneous-failures 0) (*print-length* nil))

test/try-reloading-dependency.asd

deleted100644 → 0
+0 −5
Original line number Diff line number Diff line
;;; -*- Lisp -*-
(asdf:defsystem try-reloading-dependency
    :components ((:file "file3")))