From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Tue, 12 Sep 2017 02:16:16 +0000 (-0700)
Subject: devops: Specify just one (Debian) architecture in host declarations.
X-Git-Tag: mit-scheme-pucked-9.2.12~71
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e1fcc777ff23d8dd1a704ae2d4b372c22529ca08;p=mit-scheme.git

devops: Specify just one (Debian) architecture in host declarations.
---

diff --git a/src/devops/build.scm b/src/devops/build.scm
index e475615be..1c65e84d1 100644
--- a/src/devops/build.scm
+++ b/src/devops/build.scm
@@ -184,7 +184,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
        (find (lambda (line) (string=? "DISTRIB_ID=Ubuntu" line))
 	     (file-lines "/etc/lsb-release"))))
 
-(define (debian-architecture)
+(define (read-debian-architecture)
   (car (shell-lines "dpkg-architecture -qDEB_TARGET_ARCH")))
 
 (load-option 'regular-expression)
diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index 02f45aa79..6d4a304c2 100644
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -544,7 +544,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (close-output-port i/o))
 
 (define (verify-host-debian-architecture host i/o)
-  (let ((darch (read-reply '(debian-architecture) i/o)))
+  (let ((darch (read-reply '(read-debian-architecture) i/o)))
     (if (not (string? darch))
 	(error "no Debian architecture"))
     (if (not (string=? darch (host-debian-architecture host)))
@@ -648,14 +648,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (name plugin-name)
   (directory plugin-directory))
 
-(define (host name user directory sarch darch os)
+(define (host name user directory arch os)
   (let ((duplicate (find (lambda (h) (string=? name (host-name h)))
 			 host-list)))
     (if duplicate
 	(error (string "Host "name" already defined."))))
   (set! host-list
 	(append! host-list
-		 (list (make-host name user directory sarch darch os))))
+		 (list (make-host name user directory arch os))))
   unspecific)
 
 (define (hosts) (list-copy host-list))
@@ -673,18 +673,22 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	n)))
 
 (define-record-type <host>
-    (make-host name user directory sarch darch os)
+    (make-host name user directory darch os)
     host?
   (name host-name)
   (user host-user)
   (directory host-directory)
-  (sarch host-scheme-architecture)
   (darch host-debian-architecture)
   (os host-os))
 
 (define (host-ubuntu? host)
   (os-ubuntu? (host-os host)))
 
+(define (host-scheme-architecture darch)
+  (cond ((string=? "amd64" darch) "x86-64")
+	((string=? "i386"  darch) "i386")
+	(else (error "unknown Debian architecture:" darch))))
+
 (define (host-ubuntu-codename host)
   (ubuntu-os-codename (host-os host)))