Skip to content
Snippets Groups Projects
Commit 9259a065 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.147: improve things somewhat for gcl. Merge two u-i-f-r-c methods for smaller output.

parent 69019dda
No related branches found
Tags 2.147
No related merge requests found
...@@ -49,6 +49,8 @@ ...@@ -49,6 +49,8 @@
(cl:in-package :cl-user) (cl:in-package :cl-user)
#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
;;; make package if it doesn't exist yet. ;;; make package if it doesn't exist yet.
;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
...@@ -71,7 +73,7 @@ ...@@ -71,7 +73,7 @@
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(defvar *asdf-version* nil) (defvar *asdf-version* nil)
(defvar *upgraded-p* nil) (defvar *upgraded-p* nil)
(let* ((asdf-version "2.146") ;; bump this version when you modify this file. (let* ((asdf-version "2.147") ;; bump this version when you modify this file.
(existing-asdf (fboundp 'find-system)) (existing-asdf (fboundp 'find-system))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))) (already-there (equal asdf-version existing-version)))
...@@ -323,19 +325,14 @@ ...@@ -323,19 +325,14 @@
(when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
(when (find-class 'module nil) (when (find-class 'module nil)
(eval (eval
'(progn '(defmethod update-instance-for-redefined-class :after
(defmethod update-instance-for-redefined-class :after ((m module) added deleted plist &key)
((m module) added deleted plist &key) (declare (ignorable deleted plist))
(declare (ignorable deleted plist)) (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
(when *asdf-verbose* (format *trace-output* "Updating ~A~%" m)) (when (member 'components-by-name added)
(when (member 'components-by-name added) (compute-module-components-by-name m))
(compute-module-components-by-name m))) (when (and (typep m 'system) (member 'source-file added))
(defmethod update-instance-for-redefined-class :after (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))
((s system) added deleted plist &key)
(declare (ignorable deleted plist))
(when *asdf-verbose* (format *trace-output* "Updating ~A~%" s))
(when (member 'source-file added)
(%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s)))))))
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;;; User-visible parameters ;;;; User-visible parameters
...@@ -535,11 +532,11 @@ Also, if either argument is NIL, then the other argument is returned unmodified. ...@@ -535,11 +532,11 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
(directory (pathname-directory specified)) (directory (pathname-directory specified))
(directory (directory
(cond (cond
#-(or sbcl cmu) #-(or sbcl cmu scl)
((stringp directory) `(:absolute ,directory) directory) ((stringp directory) `(:absolute ,directory) directory)
#+gcl #+gcl
((and (consp directory) (stringp (first directory))) ((and (consp directory) (not (member (first directory) '(:absolute :relative))))
`(:absolute ,@directory)) `(:relative ,@directory))
((or (null directory) ((or (null directory)
(and (consp directory) (member (first directory) '(:absolute :relative)))) (and (consp directory) (member (first directory) '(:absolute :relative))))
directory) directory)
......
...@@ -64,7 +64,6 @@ ...@@ -64,7 +64,6 @@
("**;*.*.*" ("**;*.*.*"
,(make-pathname :directory (src-dir :wild-inferiors) ,(make-pathname :directory (src-dir :wild-inferiors)
:name :wild :type :wild)))) :name :wild :type :wild))))
(let ((failures nil) (let ((failures nil)
(systems `(,(make-pathname :directory (src-dir "system1") :name nil :type nil) (systems `(,(make-pathname :directory (src-dir "system1") :name nil :type nil)
,(make-pathname :host "ASDFTEST" :directory '(:absolute "system1")) ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system1"))
...@@ -209,13 +208,12 @@ ...@@ -209,13 +208,12 @@
pathname)) pathname))
(test-module (module) (test-module (module)
(incf directory-count) (incf directory-count)
(unless #-clisp (probe-file (asdf:component-pathname module)) (unless (asdf::probe-file* (asdf:component-pathname module))
#+clisp (ext:probe-directory (asdf:component-pathname module))
(incf directory-failures) (incf directory-failures)
(push (list (type-of module) (asdf:component-name module) (push (list (type-of module) (asdf:component-name module)
(translate-if-needed (asdf:component-pathname module)) (translate-if-needed (asdf:component-pathname module))
configuration configuration
(list (when (asdf:component-parent module) (asdf:component-pathname (asdf:component-parent module))))) (list (when (asdf:component-parent module) (asdf:component-pathname (asdf:component-parent module)))))
failures))) failures)))
(test-file (file) (test-file (file)
(incf file-count) (incf file-count)
...@@ -280,7 +278,8 @@ ...@@ -280,7 +278,8 @@
(asdf:initialize-output-translations) (asdf:initialize-output-translations)
(format t "output translations: ~S~%" (asdf::output-translations)) (format t "output translations: ~S~%" (asdf::output-translations))
#-(or clisp ecl) ; clisp has problem with the first one having :version :newest #+gcl (format t "~&~A~&" (progn (defvar *x* -1) (incf *x*)))
(progn ; 1- we're testing with unix, are we not? (progn ; 1- we're testing with unix, are we not?
(assert (equal (asdf::resolve-location '(:home)) (truename (user-homedir-pathname)))) (assert (equal (asdf::resolve-location '(:home)) (truename (user-homedir-pathname))))
(assert (equal (asdf::resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz")) (assert (equal (asdf::resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz"))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment