From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Thu, 27 Dec 2018 17:31:52 +0000 (-0700)
Subject: devops: Fix version>? and move it out of build.scm.
X-Git-Tag: mit-scheme-pucked-10.1.7~4
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=71d96d80e205c9cf09dfb2d75a53b1ee2a83ef60;p=mit-scheme.git

devops: Fix version>? and move it out of build.scm.
---

diff --git a/src/devops/build.scm b/src/devops/build.scm
index 180458a3a..2403d61a3 100644
--- a/src/devops/build.scm
+++ b/src/devops/build.scm
@@ -202,14 +202,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (read-debian-architecture)
   (car (shell-lines "dpkg-architecture -qDEB_TARGET_ARCH")))
 
-(define (read-host-arch.version exe)
-  (let ((expr (string "(write-line"
-		      " (cons microcode-id/compiled-code-type"
-		      "       (get-subsystem-version \"Release\")))")))
-    (read (open-input-string
-	   (car (shell-lines exe " --batch-mode"
-			     " --eval '"expr"' --eval '(%exit)'"))))))
-
 (load-option 'regular-expression)
 
 (define (available-sources dir)
@@ -228,39 +220,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	 (directory-file-names dir #f))
 	(lambda (a b) (< (car a) (car b))))))
 
-(define (version-comparator < >)
-  (named-lambda (version-compare v1 v2)
-    (let loop ((v1 v1) (v2 v2))
-      (cond ((eq? #f v1)
-	     #t)
-	    ((eq? #f v2)
-	     #f)
-	    ((null? v2)
-	     #f)
-	    ((null? v1) ;; and (pair? v2)
-	     #t)
-	    ((< (car v1) (car v2))
-	     #t)
-	    ((> (car v1) (car v2))
-	     #f)
-	    (else
-	     (loop (cdr v1) (cdr v2)))))))
-
-(define (->version string)
-  (and string
-       (map string->number (burst-string string #\. #f))))
-
-(define (version-string version)
-  (if (pair? version)
-      (decorated-string-append "" "." ""
-       (map (lambda (num) (number->string num 10))
-	    version))
-      (error "Bad version:" version)))
-
-(define version=? equal?)
-(define version<? (version-comparator < >))
-(define version>? (version-comparator > <))
-
 (define (in-batch thunk)
   (fresh-line)
   (write-string "OK\n")
diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index 68e26b3a1..8d97afbfb 100644
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -871,6 +871,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	  (if (not (zero? plugin-errors))
 	      (error "Plugins failed to build:" plugin-errors))))))
 
+(define (read-host-arch.version exe)
+  (let ((expr (string "(write-line"
+		      " (cons microcode-id/compiled-code-type"
+		      "       (get-subsystem-version \"Release\")))")))
+    (read (open-input-string
+	   (car (shell-lines exe " --batch-mode"
+			     " --eval '"expr"' --eval '(%exit)'"))))))
+
 (define (load-make-config)
   (cond ((file-exists? "devops-config.scm")
 	 (load "devops-config.scm" '(devops)))
@@ -928,11 +936,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define (make-install-doc prefix)
   (if (not (file-exists? "doc/configure"))
-      (trun "cd doc/; autoconf"))
+      (trun "cd doc/ && autoconf"))
   (if (not (file-exists? "doc/Makefile"))
-      (trun "cd doc/; ./configure --prefix="prefix))
-  (trun "cd doc/; make all")
-  (trun "cd doc/; umask 022; make install"))
+      (trun "cd doc/ && ./configure --prefix="prefix))
+  (trun "cd doc/ && make all")
+  (trun "cd doc/ && umask 022 && make install"))
 
 (define default-plugin-names '("edwin" "imail" "x11" "x11-screen"))
 
@@ -957,18 +965,18 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	(error "Plugin directory not found:" dir))
     (log "# "dir":\n")
     (if (not (file-exists? (string dir"/configure")))
-	(trun "cd "dir"/; ./autogen.sh"))
+	(trun "cd "dir"/ && ./autogen.sh"))
     (if (not (file-exists? (string dir"/Makefile")))
-	(trun "cd "dir"/; ./configure --prefix="prefix))
-    (trun "cd "dir"/; make tags")
-    (trun "cd "dir"/; make all")
-    (trun "cd "dir"/; make check")
-    (trun "cd "dir"/; umask 022; make install")
+	(trun "cd "dir"/ && ./configure --prefix="prefix))
+    (trun "cd "dir"/ && make tags")
+    (trun "cd "dir"/ && make all")
+    (trun "cd "dir"/ && make check")
+    (trun "cd "dir"/ && umask 022 && make install")
     (if (find (lambda (line) (string-prefix? "info_TEXINFOS" line))
 	      (file-lines dir"/Makefile.am"))
 	(begin
-	  (trun "cd "dir"/; umask 022; make install-html")
-	  (trun "cd "dir"/; umask 022; make install-pdf")))))
+	  (trun "cd "dir"/ && umask 022 && make install-html")
+	  (trun "cd "dir"/ && umask 022 && make install-pdf")))))
 
 (define (trun . strings)
   ;;(log-timestamp)
@@ -1131,6 +1139,35 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	   (shell-lines "git tag -l '"package-name"-*'")))
 	(lambda (a b) (version>? (car a) (car b)))))
 
+(define (->version string)
+  (and string
+       (map string->number (burst-string string #\. #f))))
+
+(define (version-string version)
+  (if (pair? version)
+      (decorated-string-append "" "." ""
+       (map (lambda (num) (number->string num 10))
+	    version))
+      (error "Bad version:" version)))
+
+(define version=? equal?)
+
+(define (version<? v1 v2)
+  (let loop ((v1 v1) (v2 v2))
+    (cond ((null? v2)
+	   #f)
+	  ((null? v1)
+	   #t)
+	  ((< (car v1) (car v2))
+	   #t)
+	  ((> (car v1) (car v2))
+	   #f)
+	  (else
+	   (loop (cdr v1) (cdr v2))))))
+
+(define (version>? v1 v2)
+  (version<? v2 v1))
+
 (define (match-extract match key)
   (let ((entry (assq key (cddr match))))
     (if entry