(burst-string (match-extract match 'version)
#\space #t))
(if (eof-object? line)
- (error "could not find core version")
+ (error "Could not find core version.")
(loop)))))))))
(define (make-news-pattern fullname)
line))))
(if match
(->version (match-extract match 'version))
- (error "no plugin version:" (plugin-name plugin))))
+ (error "No plugin version:" (plugin-name plugin))))
(if (eof-object? line)
- (error "no AC_INIT:" (plugin-name plugin))
+ (error "No AC_INIT:" (plugin-name plugin))
(loop))))))))
(define (plugin-changes plugin)
(define (release-core version changes dirt snap?)
(if (and (null? changes) (not snap?))
- (error "no unreleased commits"))
+ (error "No unreleased commits."))
(let* ((project (project-name))
(vers (version-string version))
(pkgvers (string project"-"vers))
(define (release-plugin plugin version changes dirt snap?)
(if (and (null? changes) (not snap?))
- (error "no unreleased commits"))
+ (error "No unreleased commits."))
(let* ((vers (version-string version))
(pkg (plugin-package plugin))
(pkgvers (string pkg"-"vers))
(found)
(release-core version changes dirt #t)))
(else
- (error "version has not incremented:" version)))))
+ (error "Version has not incremented:" version)))))
(define (snapshot-plugin plugin dirt)
(let* ((changes (or (plugin-changes plugin) '()))
(found)
(release-plugin plugin version changes dirt #t)))
(else
- (error "version has not incremented:" version)))))
+ (error "Version has not incremented:" version)))))
\f
;;;; Build
(let ((srcs (available-sources "devops"))
(hosts (hosts)))
(if (null? hosts)
- (error "no build hosts defined")
+ (error "No build hosts defined.")
(if (default-object? hostname)
(for-each (lambda (host) (write-host-status host srcs))
hosts)
(lambda (i/o)
(let ((reply (read-reply '(quote ready) i/o)))
(if (not (eq? reply 'ready))
- (error "not ready:" reply)))
+ (error "Build host not ready:" reply)))
(let ((reply (read-reply `(let ((dirname ,(host-directory host)))
(if (and (file-exists? dirname)
(file-directory? dirname))
(cond ((eq? reply 'yes)
unspecific)
((eq? reply 'no)
- (error "no build directory:" (host-directory host)))
- (else (error "unexpected reply:" reply))))
+ (error "No build directory:" (host-directory host)))
+ (else (error "Unexpected reply:" reply))))
(let ((files (read-reply `(directory-file-names ,(host-directory host) #f)
i/o))
(proj (project-name))
(sarch (host-scheme-architecture host))
(darch (host-debian-architecture host)))
(if (not (list-of-type? files string?))
- (error "unexpected filename list:" files))
+ (error "Unexpected filename list:" files))
(write-lock-report host i/o files)
(for-each
(lambda (src)
(let ((sys (system-library-pathname "devops/build.scm" #f)))
(if (file-exists? sys)
sys
- (error "could not find build script")))))
+ (error "Could not find build script.")))))
i/o)
(verify-host-architecture host i/o)
(flush-output-port i/o)
(let ((reply (read-reply '(quote ok) i/o)))
(if (not (eq? reply 'ok))
- (error "not OK")))
+ (error "Build host not OK.")))
(close-input-port i/o)
(close-output-port i/o))
(begin
(let ((darch (read-reply '(read-debian-architecture) i/o)))
(if (not (string? darch))
- (error "no Debian architecture"))
+ (error "No Debian architecture."))
(if (not (string=? darch (host-debian-architecture host)))
- (error "wrong Debian architecture")))
+ (error "Wrong Debian architecture.")))
(let ((str (read-reply '(if (ubuntu?) "yes" "no") i/o)))
(if (not (string? str))
- (error "no Ubuntu-ness"))
+ (error "No Ubuntu-ness."))
(let ((ubu? (string=? "yes" str)))
(if (not (eq? ubu? (host-ubuntu? host)))
- (error "wrong Ubuntu-ness")))))))
+ (error "Wrong Ubuntu-ness.")))))))
(define (call-with-host-i/o host receiver)
(call-with-current-continuation
(define (devops:make target)
(if (not (member target '("native" "svm" "C" "C-old" "C2native" "C2svm")))
- (error "unknown build target:" target))
+ (error "Unknown build target:" target))
(load-make-config)
(%exit
(call-with-current-continuation ;throw here to unwind all
(define (devops:make* target)
(let* ((prefix (or (get-environment-variable "PWD")
- (error "PWD not set")))
+ (error "PWD not set.")))
(host-exe (or (get-environment-variable "MIT_SCHEME_EXE")
"mit-scheme"))
(target-exe 'unset))
(lndir "../doc")
(make-install-doc prefix)
(for-each lndir '("../src" "../tests")))
- (error "not a git working directory:"
+ (error "Not a git working directory:"
(working-directory-pathname))))
;;(set-environment-variable! "LD_LIBRARY_PATH" "/usr/local/lib")
(map (lambda (plugin) (make-install-plugin plugin prefix))
plugin-list))))))
(if (not (zero? plugin-errors))
- (error "plugins failed to build:" plugin-errors)))))
+ (error "Plugins failed to build:" plugin-errors)))))
(define (load-make-config)
(cond ((file-exists? "devops-config.scm")
(begin (load file '(devops))
#t))))
(else
- (error "no devops test configuration found"))))
+ (error "No devops test configuration found."))))
(define make-config "")
(define (make-configuration . args)
(define (make-install-plugin* plugin prefix)
(let ((dir (plugin-directory plugin)))
(if (not (file-directory? dir))
- (error "plugin directory not found:" dir))
+ (error "Plugin directory not found:" dir))
(log "# "dir":\n")
(if (not (file-exists? (string dir"/configure")))
(trun "cd "dir"/; ./autogen.sh"))
(let ((n (string name)))
(or (find (lambda (p) (string=? n (plugin-name p)))
plugin-list)
- (error "no such plugin:" name))))
+ (error "No such plugin:" name))))
(define-record-type <plugin>
(make-plugin name directory)
((string=? "i386" arch) "i386")
((string=? "svm1-32" arch) #f)
((string=? "svm1-64" arch) #f)
- (else (error "unknown host architecture:" arch)))))
+ (else (error "Unknown host architecture:" arch)))))
(define (host-ubuntu-codename host)
(ubuntu-os-codename (host-os host)))
(define (find-git-root)
(let ((pwd (drop-slash (or (get-environment-variable "PWD")
- (error "PWD not set")))))
+ (error "PWD not set.")))))
(let loop ((parent (drop-slash (dirname pwd))))
(if (string-null? parent)
- (error "no git root found:" pwd)
+ (error "No git root found:" pwd)
(if (file-directory? (string parent"/.git"))
parent
(loop (drop-slash (dirname pwd))))))))
projects / mit-scheme.git / commitdiff