Commit 8914d4b5 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.122: Replace if-bind by if-let from alexandira.

Have one bigger lisp script to replace several shell scripts.
parent eceb8c10
?
??
???
build
doc/asdf/
......
......@@ -54,12 +54,12 @@ load: build/asdf.lisp
install: archive-copy
bump-version: build/asdf.lisp
./bin/bump-version
./bin/asdf-builder bump-version
archive: build/asdf.lisp
#${SBCL} --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \
# --eval "(rewrite-license)" --eval "(quit)"
./bin/make-tarball
./bin/asdf-builder make-tarballs
archive-copy: archive build/asdf.lisp
git checkout release
......
......@@ -92,7 +92,7 @@ You can put together sentences using this phrase."))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF3: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component))
`(,@(if-bind (p (component-parent c)) `((,o ,p))) ,@(call-next-method)))
`(,@(if-let (p (component-parent c)) `((,o ,p))) ,@(call-next-method)))
;;;; Inputs, Outputs, and invisible dependencies
......
......@@ -15,7 +15,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.111" ;; to be automatically updated by bin/bump-revision
:version "2.26.112" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
......@@ -4,20 +4,25 @@
(load (make-pathname :name "prelude" :type "lisp" :defaults *load-pathname*)
:verbose nil :print nil)
;;;;; create tarball for the current version.
(defpackage :asdf-builder (:use :cl :asdf/driver :asdf :fare-utils))
(in-package :asdf-builder)
(in-package :asdf)
(asdf-debug)
(defun build-asdf ()
;; Make sure asdf.lisp is built.
(asdf:build-system :asdf/generate))
;;; Make sure asdf.lisp is built.
(asdf:build-system :asdf/generate)
;;; ASDF directory
(defparameter *asdf-dir*
(defvar *asdf-dir*
(ensure-pathname (system-relative-pathname :asdf ())
:want-physical t :want-absolute t
:want-existing t :ensure-truename t))
(defparameter /asdf-dir/
(native-namestring *asdf-dir*))
(defun apath (x &rest keys) (apply 'subpathname *asdf-dir* x keys))
;;; build directory
(defparameter *build-dir*
......@@ -32,8 +37,6 @@
(safe-read-file-form
(subpathname *asdf-dir* "version.lisp-expr")))
(defparameter *asdf-driver* (format nil "asdf-driver-~A" *version*))
(defun enough-namestring! (base pathname)
(let ((e (enough-namestring base pathname)))
(assert (relative-pathname-p e))
......@@ -58,16 +61,6 @@
(pathnames (mapcar 'component-pathname components)))
(enough-namestrings dir pathnames)))
(defparameter *driver-files*
(list* "asdf-driver.asd" "version.lisp-expr"
(system-source-files :asdf-driver)))
(defparameter *asdf-only*
(format nil "asdf-only-~A" *version*))
(defparameter *asdf-only-files*
(list* "asdf.asd" "version.lisp-expr"
(system-source-files :asdf/generate)))
(defun tarname (name) (strcat name ".tar.gz"))
(defun run-program* (x)
......@@ -110,12 +103,141 @@
(ensure-directories-exist destination)
(run-program* (format nil "cd ~S && cp -lax --parents ~{~S ~} ~S"
/base/ /files/ /destination/))
(run-program* (format nil "tar zcvfC ~S ~S ~S/"
(run-program* (format nil "tar zcfC ~S ~S ~S/"
/tarball/ /build-dir/ name))
(run-program* `("rm" "-rf" ,/destination/))))
(make-tarball-under-build *asdf-driver* *asdf-dir* *driver-files*)
(make-tarball-under-build *asdf-only* *asdf-dir* *asdf-only-files*)
(defun driver-files ()
(list* "asdf-driver.asd" "version.lisp-expr"
(system-source-files :asdf-driver)))
(defun driver-name ()
(format nil "asdf-driver-~A" *version*))
(defun make-driver-tarball ()
(make-tarball-under-build (driver-name) *asdf-dir* (driver-files)))
(run-program* (format nil "cd ~S && tar zcf build/asdf-~A.tar.gz build/asdf.lisp $(git ls-files)"
/asdf-dir/ *version*))
(defun asdf-only-files ()
(list* "asdf.asd" "version.lisp-expr" "header.lisp"
(system-source-files :asdf/generate)))
(defun asdf-only-name ()
(format nil "asdf-only-~A" *version*))
(defun make-asdf-only-tarball ()
(make-tarball-under-build (asdf-only-name) *asdf-dir* (asdf-only-files)))
(defun make-git-tarball ()
(run-program* (format nil "cd ~S && tar zcf build/asdf-~A.tar.gz build/asdf.lisp $(git ls-files)"
/asdf-dir/ *version*)))
(defun make-tarballs ()
(make-driver-tarball)
(make-asdf-only-tarball)
(make-git-tarball))
(defparameter *versioned-files*
'(("version.lisp-expr" "\"" "\"")
("asdf.asd" " :version \"" "\" ;; to be automatically updated by bin/bump-revision")
("header.lisp" "This is ASDF " ": Another System Definition Facility.")
("upgrade.lisp" " (asdf-version \"" "\")")))
(defparameter *version-file*
(apath "version.lisp-expr"))
(defparameter *old-version* nil)
(defparameter *new-version* nil)
(defun next-version (v)
(let ((pv (parse-version v 'error)))
(incf (third pv))
(unparse-version pv)))
(defun version-from-file ()
(safe-read-file-form *version-file*))
(defun versions-from-args (&optional v1 v2)
(labels ((check (old new)
(parse-version old 'error)
(parse-version new 'error)
(values old new)))
(cond
((and v1 v2) (check v1 v2))
(v1 (check (version-from-file) v1))
(t (let ((old (version-from-file)))
(check old (next-version old)))))))
(deftype byte-vector () '(array (unsigned-byte 8) (*)))
(defun maybe-replace-file (file transformer
&key (reader 'read-file-string)
(writer nil) (comparator 'equalp)
(external-format *utf-8-external-format*))
(format t "Transforming file ~A... " (file-namestring file))
(let* ((old-contents (funcall reader file))
(new-contents (funcall transformer old-contents)))
(if (funcall comparator old-contents new-contents)
(format t "no changes needed!~%")
(let ((written-contents
(if writer
(with-output (s ())
(funcall writer s new-contents))
new-contents)))
(check-type written-contents (or string (byte-vector)))
(clobber-file-with-vector file written-contents :external-format external-format)
(format t "done.~%")))))
(defun version-transformer (new-version file prefix suffix &optional dont-warn)
(let* ((qprefix (cl-ppcre:quote-meta-chars prefix))
(versionrx "([0-9]+(\\.[0-9]+)+)")
(qsuffix (cl-ppcre:quote-meta-chars suffix))
(regex (strcat "(" qprefix ")(" versionrx ")(" qsuffix ")"))
(replacement
(constantly (strcat prefix new-version suffix))))
(lambda (text)
(multiple-value-bind (new-text foundp)
(cl-ppcre:regex-replace regex text replacement)
(unless (or foundp dont-warn)
(warn "Missing version in ~A" (file-namestring file)))
(values new-text foundp)))))
(defun transform-file (new-version file prefix suffix)
(maybe-replace-file (apath file) (version-transformer new-version file prefix suffix)))
(defun transform-files (new-version)
(loop :for f :in *versioned-files* :do (apply 'transform-file new-version f)))
(defun test-transform-file (new-version file prefix suffix)
(let ((lines (read-file-lines (apath file))))
(dolist (l lines (progn (warn "Couldn't find a match in ~A" file) nil))
(multiple-value-bind (new-text foundp)
(funcall (version-transformer new-version file prefix suffix t) l)
(when foundp
(format t "Found a match:~% ==> ~A~%Replacing with~% ==> ~A~%~%"
l new-text)
(return t))))))
(defun test-transform (new-version)
(apply 'test-transform-file new-version (first *versioned-files*)))
(defun bump-version (&optional v1 v2)
(multiple-value-bind (old-version new-version)
(versions-from-args v1 v2)
(a "Bumping ASDF version from " old-version " to " new-version)
(transform-files new-version)
(a "Rebuilding ASDF with bumped version")
(build-asdf)))
(defun git-version ()
(first (run-program/ '("git" "describe" "--tags" "--match" "[0-9].[0-9][0-9]") :output :lines)))
;;;; Main entry point
(defun main (args)
(block nil
(unless args
(format t "No command provided~%")
(return))
(if-let (sym (find-symbol* (string-upcase (first args)) :asdf-builder nil))
(let ((results (multiple-value-list (apply sym (rest args)))))
(when results
(format t "~&Results:~%~{ ~S~%~}" results)))
(format t "Command ~A not found~%" (first args)))))
(main *command-line-arguments*)
#!/bin/sh
# write the highest tag to standard output
# exit code is 1 if it cannot be found
tag=`git describe --tags --match '[0-9].[0-9][0-9]'`
if [ "$tag" == "" ]; then
exit 1
fi
echo $tag
exit 0
#!/bin/sh
":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
;;; Really runs on any decent Common Lisp implementation
(load (make-pathname :name "prelude" :type "lisp" :defaults *load-pathname*)
:verbose nil :print nil)
(in-package :fare-utils)
(asdf-debug)
(defparameter *versioned-files*
'(("version.lisp-expr" "\"" "\"")
("asdf.asd" " :version \"" "\" ;; to be automatically updated by bin/bump-revision")
("header.lisp" "This is ASDF " ": Another System Definition Facility.")
("upgrade.lisp" " (asdf-version \"" "\")")))
(defvar *adir* (asdf:system-relative-pathname :asdf nil))
(defun afile (x) (subpathname *adir* x))
(defparameter *version-file*
(afile "version.lisp-expr"))
(defparameter *old-version* nil)
(defparameter *new-version* nil)
(defun next-version (v)
(let ((pv (parse-version v 'error)))
(incf (third pv))
(unparse-version pv)))
(defun version-from-file ()
(safe-read-file-form *version-file*))
(defun versions-from-argv (argv)
(labels ((check (old new)
(parse-version old 'error)
(parse-version new 'error)
(values old new)))
(ecase (length argv)
((2) (check (second argv) (first argv)))
((1) (check (version-from-file) (first argv)))
((0) (let ((old (version-from-file)))
(check old (next-version old)))))))
(multiple-value-setq (*old-version* *new-version*)
(versions-from-argv *command-line-arguments*))
(a "Bumping ASDF version from " *old-version* " to " *new-version*)
(deftype byte-vector () '(array (unsigned-byte 8) (*)))
(defun maybe-replace-file (file transformer
&key (reader 'read-file-string)
(writer nil) (comparator 'equalp)
(external-format *utf-8-external-format*))
(format t "Transforming file ~A... " (file-namestring file))
(let* ((old-contents (funcall reader file))
(new-contents (funcall transformer old-contents)))
(if (funcall comparator old-contents new-contents)
(format t "no changes needed!~%")
(let ((written-contents
(if writer
(with-output (s ())
(funcall writer s new-contents))
new-contents)))
(check-type written-contents (or string (byte-vector)))
(clobber-file-with-vector file written-contents :external-format external-format)
(format t "done.~%")))))
(defun version-transformer (new-version file prefix suffix &optional dont-warn)
(let* ((qprefix (cl-ppcre:quote-meta-chars prefix))
(versionrx "([0-9]+(\\.[0-9]+)+)")
(qsuffix (cl-ppcre:quote-meta-chars suffix))
(regex (strcat "(" qprefix ")(" versionrx ")(" qsuffix ")"))
(replacement
(constantly (strcat prefix new-version suffix))))
(lambda (text)
(multiple-value-bind (new-text foundp)
(cl-ppcre:regex-replace regex text replacement)
(unless (or foundp dont-warn)
(warn "Missing version in ~A" (file-namestring file)))
(values new-text foundp)))))
(defun transform-file (new-version file prefix suffix)
(maybe-replace-file (afile file) (version-transformer new-version file prefix suffix)))
(defun transform-files ()
(loop :for f :in *versioned-files* :do (apply 'transform-file *new-version* f)))
(defun test-transform-file (new-version file prefix suffix)
(let ((lines (read-file-lines (afile file))))
(dolist (l lines (progn (warn "Couldn't find a match in ~A" file) nil))
(multiple-value-bind (new-text foundp)
(funcall (version-transformer new-version file prefix suffix t) l)
(when foundp
(format t "Found a match:~% ==> ~A~%Replacing with~% ==> ~A~%~%"
l new-text)
(return t))))))
(defun z () (apply 'test-transform-file *new-version* (first *versioned-files*)))
(transform-files)
(a "Re-generate ASDF with bumped version")
(asdf:build-system :asdf/generate)
(setf *load-verbose* nil *load-print* nil
*compile-verbose* nil *compile-print* nil)
(format t "Loading your implementation's ASDF... ~%")
(require :asdf)
(in-package :asdf)
#-asdf2 (error "Not ASDF2, you lose!")
(format t "Initializing the source registry... ~%")
(initialize-source-registry)
(format t "Upgrading to the latest ASDF... ~%")
(upgrade-asdf)
(format t "At ASDF ~A.~%" (asdf-version))
(format t "Now loading some dependencies... ~%")
(load-systems :cl-ppcre :fare-utils)
(format t "There we are!~%")
(restore-image)
......@@ -295,7 +295,7 @@
(defmethod component-depends-on :around ((o bundle-op) (c component))
(declare (ignorable o c))
(if-bind (op (and (eq (type-of o) 'bundle-op) (component-bundle-operation c)))
(if-let (op (and (eq (type-of o) 'bundle-op) (component-bundle-operation c)))
`((,op ,c))
(call-next-method)))
......
......@@ -121,7 +121,7 @@ another pathname in a degenerate way."))
(format stream "~{~S~^ ~}" (component-find-path c))))
(defmethod component-system ((component component))
(if-bind (system (component-parent component))
(if-let (system (component-parent component))
(component-system system)
component))
......
......@@ -57,7 +57,7 @@
(cond
((os-unix-p) '(#p"/etc/common-lisp/"))
((os-windows-p)
(if-bind (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/"))
(if-let (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/"))
(list it)))))
(defun* in-first-directory (dirs x &key (direction :input))
......
......@@ -91,7 +91,7 @@ of which is a system object.")
(asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
(unless (eq system (cdr (gethash name *defined-systems*)))
(setf (gethash name *defined-systems*)
(cons (if-bind (file (ignore-errors (system-source-file system)))
(cons (if-let (file (ignore-errors (system-source-file system)))
(safe-file-write-date file))
system)))))
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.111: Another System Definition Facility.
;;; This is ASDF 2.26.112: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -71,7 +71,7 @@
nil)
(defmethod input-files ((o prepare-op) (s system))
(declare (ignorable o))
(if-bind (it (system-source-file s)) (list it)))
(if-let (it (system-source-file s)) (list it)))
;;; compile-op
(defmethod operation-description ((o compile-op) (c component))
......@@ -158,7 +158,7 @@
(component-name c)))
(perform (find-operation o 'compile-op) c)))))
(defun* perform-lisp-load-fasl (o c)
(if-bind (fasl (first (input-files o c)))
(if-let (fasl (first (input-files o c)))
(with-muffled-loader-conditions () (load* fasl))))
(defmethod perform ((o load-op) (c cl-source-file))
(perform-lisp-load-fasl o c))
......@@ -187,7 +187,7 @@
nil)
(defmethod input-files ((o prepare-source-op) (s system))
(declare (ignorable o))
(if-bind (it (system-source-file s)) (list it)))
(if-let (it (system-source-file s)) (list it)))
(defmethod perform ((o prepare-source-op) (c component))
(declare (ignorable o c))
nil)
......
......@@ -257,7 +257,7 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
#+clozure #p"ccl:"
#+(or ecl mkcl) #p"SYS:"
#+gcl system::*system-directory*
#+sbcl (if-bind (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
#+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
(funcall it)
(getenv-pathname "SBCL_HOME" :ensure-directory t)))))
(if (and dir truename)
......
......@@ -374,7 +374,7 @@ with given pathname and if it exists return its truename."
(pathname (unless (wild-pathname-p p)
#.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl)
'(probe-file p)
#+clisp (if-bind (it (find-symbol* '#:probe-pathname :ext nil))
#+clisp (if-let (it (find-symbol* '#:probe-pathname :ext nil))
`(ignore-errors (,it p)))
#+gcl<2.7
'(or (probe-file p)
......
......@@ -105,7 +105,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
(:documentation "Is this action valid to include amongst dependencies?"))
(defmethod action-valid-p (plan operation (c component))
(declare (ignorable plan operation))
(if-bind (it (component-if-feature c)) (featurep it) t))
(if-let (it (component-if-feature c)) (featurep it) t))
(defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil)
(defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil)
......@@ -140,7 +140,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
;; In a distant future, safe-file-write-date and component-operation-time
;; shall also be parametrized by the plan, or by a second model object.
(let* ((stamp-lookup #'(lambda (o c)
(if-bind (it (plan-action-status plan o c)) (action-stamp it) t)))
(if-let (it (plan-action-status plan o c)) (action-stamp it) t)))
(out-files (output-files o c))
(in-files (input-files o c))
;; Three kinds of actions:
......
......@@ -23,8 +23,8 @@
(unless (let ((vs (find-symbol* 'version-satisfies :asdf nil))
(av (find-symbol* 'asdf-version :asdf nil)))
(and vs av (funcall vs (funcall av) "2.26.59")))
(if-bind (p (find-package :asdf))
(do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))))
(if-let (p (find-package :asdf))
(do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))))
;;; Special magic to detect if this is an upgrade
......@@ -45,7 +45,7 @@
;; "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.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.111")
(asdf-version "2.26.112")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
......
......@@ -9,7 +9,7 @@
;; magic helper to define debugging functions:
#:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
#:undefine-function #:undefine-functions #:defun* #:defgeneric* ;; (un)defining functions
#:if-bind ;; basic flow control
#:if-let ;; basic flow control
#:while-collecting #:appendf #:length=n-p #:remove-keys #:remove-key ;; lists and plists
#:emptyp ;; sequences
#:first-char #:last-char #:split-string ;; strings
......@@ -89,9 +89,16 @@
;;; Flow control
(defmacro if-bind ((var test) then &optional else)
`(let ((,var ,test)) (if ,var ,then ,else)))
(defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
;; bindings can be (var form) or ((var1 form1) ...)
(let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
(list bindings)
bindings))
(variables (mapcar #'car binding-list)))
`(let ,binding-list
(if (and ,@variables)
,then-form
,else-form))))
;;; List manipulation
(defmacro while-collecting ((&rest collectors) &body body)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment