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

2.018.5: simplifying a few internals, introducing strcat.

parent 42935bf0
No related branches found
No related tags found
No related merge requests found
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.018.4" ;; to be automatically updated by bin/bump-revision :version "2.018.5" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components :components
((:file "asdf") ((:file "asdf")
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.018.4: Another System Definition Facility. ;;; This is ASDF 2.018.5: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
...@@ -86,6 +86,8 @@ ...@@ -86,6 +86,8 @@
(find-symbol (string s) p)) (find-symbol (string s) p))
;; Strip out formatting that is not supported on Genera. ;; Strip out formatting that is not supported on Genera.
;; Has to be inside the eval-when to make Lispworks happy (!) ;; Has to be inside the eval-when to make Lispworks happy (!)
(defun strcat (&rest strings)
(apply 'concatenate 'string strings))
(defmacro compatfmt (format) (defmacro compatfmt (format)
#-(or gcl genera) format #-(or gcl genera) format
#+(or gcl genera) #+(or gcl genera)
...@@ -94,10 +96,8 @@ ...@@ -94,10 +96,8 @@
'(("~3i~_" . "")) '(("~3i~_" . ""))
#+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
(loop :for found = (search unsupported format) :while found :do (loop :for found = (search unsupported format) :while found :do
(setf format (setf format (strcat (subseq format 0 found) replacement
(concatenate 'simple-string (subseq format (+ found (length unsupported)))))))
(subseq format 0 found) replacement
(subseq format (+ found (length unsupported)))))))
format) format)
(let* (;; For bug reporting sanity, please always bump this version when you modify this file. (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
;; Please also modify asdf.asd to reflect this change. The script bin/bump-version ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
...@@ -107,7 +107,7 @@ ...@@ -107,7 +107,7 @@
;; "2.345.6" would be a development version in the official upstream ;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.018.4") (asdf-version "2.018.5")
(existing-asdf (find-class 'component nil)) (existing-asdf (find-class 'component nil))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))) (already-there (equal asdf-version existing-version)))
...@@ -185,7 +185,7 @@ ...@@ -185,7 +185,7 @@
(push sym bothly-exported-symbols) (push sym bothly-exported-symbols)
(push sym formerly-exported-symbols))) (push sym formerly-exported-symbols)))
(loop :for sym :in export :do (loop :for sym :in export :do
(unless (member sym bothly-exported-symbols :test 'string-equal) (unless (member sym bothly-exported-symbols :test 'equal)
(push sym newly-exported-symbols))) (push sym newly-exported-symbols)))
(loop :for user :in (package-used-by-list package) (loop :for user :in (package-used-by-list package)
:for shadowing = (package-shadowing-symbols user) :do :for shadowing = (package-shadowing-symbols user) :do
...@@ -892,24 +892,21 @@ with given pathname and if it exists return its truename." ...@@ -892,24 +892,21 @@ with given pathname and if it exists return its truename."
(host (pathname-host pathname)) (host (pathname-host pathname))
(port (ext:pathname-port pathname)) (port (ext:pathname-port pathname))
(directory (pathname-directory pathname))) (directory (pathname-directory pathname)))
(flet ((not-unspecific (component) (if (or (ununspecific port)
(and (not (eq component :unspecific)) component))) (and (ununspecific host) (plusp (length host)))
(cond ((or (not-unspecific port) (ununspecific scheme))
(and (not-unspecific host) (plusp (length host))) (let ((prefix ""))
(not-unspecific scheme)) (when (ununspecific port)
(let ((prefix "")) (setf prefix (format nil ":~D" port)))
(when (not-unspecific port) (when (and (ununspecific host) (plusp (length host)))
(setf prefix (format nil ":~D" port))) (setf prefix (strcat host prefix)))
(when (and (not-unspecific host) (plusp (length host))) (setf prefix (strcat ":" prefix))
(setf prefix (concatenate 'string host prefix))) (when (ununspecific scheme)
(setf prefix (concatenate 'string ":" prefix)) (setf prefix (strcat scheme prefix)))
(when (not-unspecific scheme) (assert (and directory (eq (first directory) :absolute)))
(setf prefix (concatenate 'string scheme prefix))) (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
(assert (and directory (eq (first directory) :absolute))) :defaults pathname)))
(make-pathname :directory `(:absolute ,prefix ,@(rest directory)) pathname))
:defaults pathname)))
(t
pathname)))))
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;;; ASDF Interface, in terms of generic functions. ;;;; ASDF Interface, in terms of generic functions.
...@@ -1449,11 +1446,10 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" ...@@ -1449,11 +1446,10 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
(file-position s (+ start (file-position s (+ start
network-volume-offset network-volume-offset
#x14)))) #x14))))
(concatenate 'string (strcat (read-null-terminated-string s)
(read-null-terminated-string s) (progn
(progn (file-position s (+ start remaining-offset))
(file-position s (+ start remaining-offset)) (read-null-terminated-string s))))))
(read-null-terminated-string s))))))
(defun* parse-windows-shortcut (pathname) (defun* parse-windows-shortcut (pathname)
(with-open-file (s pathname :element-type '(unsigned-byte 8)) (with-open-file (s pathname :element-type '(unsigned-byte 8))
...@@ -1598,7 +1594,7 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -1598,7 +1594,7 @@ Going forward, we recommend new users should be using the source-registry.
(let ((shortcut (let ((shortcut
(make-pathname (make-pathname
:defaults defaults :version :newest :case :local :defaults defaults :version :newest :case :local
:name (concatenate 'string name ".asd") :name (strcat name ".asd")
:type "lnk"))) :type "lnk")))
(when (probe-file* shortcut) (when (probe-file* shortcut)
(let ((target (parse-windows-shortcut shortcut))) (let ((target (parse-windows-shortcut shortcut)))
...@@ -2635,7 +2631,7 @@ created with the same initargs as the original one. ...@@ -2635,7 +2631,7 @@ created with the same initargs as the original one.
")) "))
(setf (documentation 'oos 'function) (setf (documentation 'oos 'function)
(format nil (format nil
"Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a" "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
operate-docstring)) operate-docstring))
(setf (documentation 'operate 'function) (setf (documentation 'operate 'function)
operate-docstring)) operate-docstring))
...@@ -2725,8 +2721,7 @@ Returns the new tree (which probably shares structure with the old one)" ...@@ -2725,8 +2721,7 @@ Returns the new tree (which probably shares structure with the old one)"
(defvar *serial-depends-on* nil) (defvar *serial-depends-on* nil)
(defun* sysdef-error-component (msg type name value) (defun* sysdef-error-component (msg type name value)
(sysdef-error (concatenate 'string msg (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
(compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
type name value)) type name value))
(defun* check-component-input (type name weakly-depends-on (defun* check-component-input (type name weakly-depends-on
...@@ -2961,7 +2956,7 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." ...@@ -2961,7 +2956,7 @@ output to *VERBOSE-OUT*. Returns the shell's exit code."
(ccl:run-program (ccl:run-program
(cond (cond
((os-unix-p) "/bin/sh") ((os-unix-p) "/bin/sh")
((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE! ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
(t (error "Unsupported OS"))) (t (error "Unsupported OS")))
(if (os-unix-p) (list "-c" command) '()) (if (os-unix-p) (list "-c" command) '())
:input nil :output *verbose-out* :wait t))) :input nil :output *verbose-out* :wait t)))
...@@ -3725,7 +3720,7 @@ effectively disabling the output translation facility." ...@@ -3725,7 +3720,7 @@ effectively disabling the output translation facility."
(defun* tmpize-pathname (x) (defun* tmpize-pathname (x)
(make-pathname (make-pathname
:name (format nil "ASDF-TMP-~A" (pathname-name x)) :name (strcat "ASDF-TMP-" (pathname-name x))
:defaults x)) :defaults x))
(defun* delete-file-if-exists (x) (defun* delete-file-if-exists (x)
......
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