From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Sat, 24 Nov 2018 22:46:42 +0000 (-0700)
Subject: devops: New build procedure for 10.1.
X-Git-Tag: mit-scheme-pucked-10.1.2~14
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7d7d0ab029812e7d01670a994376d448777d3740;p=mit-scheme.git

devops: New build procedure for 10.1.
---

diff --git a/src/devops/build.scm b/src/devops/build.scm
index 2403d61a3..ffe48eabb 100644
--- a/src/devops/build.scm
+++ b/src/devops/build.scm
@@ -202,6 +202,14 @@ 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)
@@ -220,6 +228,39 @@ 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")
@@ -362,7 +403,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		     (not (string-prefix? prefix elt)))
 		   (vector->list scheme-subprocess-environment))))))
 
-(let ((len (vector-length scheme-subprocess-environment)))
+#;(let ((len (vector-length scheme-subprocess-environment)))
   (let loop ((i 0))
     (if (fix:< i len)
 	(let ((setting (vector-ref scheme-subprocess-environment i)))
diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index c19d097d7..03d252fef 100644
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -748,7 +748,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 ;;;; Make
 
 (define (devops:make target)
-  (if (not (member target '("native" "svm" "C" "C-old" "C2native" "C2svm")))
+  (if (not (member target '(#f "svm" "C" "x86-64" "i386")))
       (error "Unknown build target:" target))
   (load-make-config)
   (exit
@@ -778,96 +778,98 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		     (error "PWD not set.")))
 	 (host-exe (or (get-environment-variable "MIT_SCHEME_EXE")
 		       "mit-scheme"))
-	 (target-exe 'unset))
-    (if (file-directory? ".git")
-	(make-install-doc prefix)
-	(if (file-directory? "../.git")
-	    (begin
-	      (lndir "../doc")
-	      (make-install-doc prefix)
-	      (for-each lndir '("../src" "../tests")))
-	    (error "Not a git working directory:"
-		   (working-directory-pathname))))
+	 (a.v (read-host-arch.version host-exe))
+	 (host-arch (symbol->string (car a.v)))
+	 (host-version (cdr a.v))
+	 (cross? (or (and target (not (string=? target host-arch)))
+		     (not (version>? host-version '(9 2)))))
+	 (master? (cond ((file-directory? ".git")
+			 (not (file-directory? "debian")))
+			((file-directory? "../.git")
+			 (not (file-directory? "../debian")))
+			(else (error "Not a git working directory:"
+				     (working-directory-pathname))))))
 
     ;;(set-environment-variable! "LD_LIBRARY_PATH" "/usr/local/lib")
     (set-subprocess-environment-variable! "FAST" "please")
     (delete-subprocess-environment-variable! "DISPLAY")
 
-    (log "# Host: "host-exe"\n")
+    (log "# Host: "host-arch" "(version-string host-version)" "host-exe"\n")
     (log "# Target: "target"\n")
     (log "# Config: "make-config"\n")
 
-    (cond
-     ((equal? target "native")
-      (if (not (file-exists? "src/configure"))
-	  (trun "cd src/; ./Setup.sh"))
-      (if (not (file-exists? "src/Makefile"))
-	  (trun "cd src/; ./configure --prefix="prefix" "make-config))
-      (trun "cd src/; make tags")
-      (trun "cd src/; make all")
-      (trun "cd src/; make check")
-      (trun "cd src/; umask 022; make install")
-      (set! target-exe (project-name)))
-
-     ((equal? target "svm")
-      (if (not (file-exists? "src/configure"))
-	  (trun "cd src/; ./Setup.sh"))
-      (if (not (file-exists? "src/Makefile"))
-	  (trun "cd src/; ./configure" " --prefix="prefix
-		" --enable-cross-compiling --enable-native-code=svm "
-		make-config))
-      (trun "cd src/; make tags")
-      (trun "cd src/; make all")
-      (trun "cd src/; make check")
-      (trun "cd src/; umask 022; make install")
-      (set! target-exe (string (project-name)"-svm1")))
-
-     ((equal? target "C")
-      (if (not (file-exists? "src/configure"))
-	  (trun "cd src/; ./Setup.sh"))
-      (if (not (file-exists? "src/Makefile"))
-	  (trun "cd src/; ./configure --prefix="prefix
-		" --enable-native-code=C "make-config))
-      (trun "cd src/; make tags")
-      (trun "cd src/; make all-native")
-      (trun "cd src/; make check")
-      (trun "cd src/; umask 022; make install")
-      (set! target-exe (string (project-name)"-c")))
-
-     ((equal? target "C-old")
-      (trun "cd src/; make tags")
-      (trun "cd src/; ./etc/make-liarc-dist.sh --prefix="prefix" "make-config)
-      (trun "cd src/; ./etc/make-liarc.sh --prefix="prefix" "make-config)
-      (trun "cd src/; make check")
-      (trun "cd src/; umask 022; make install")
-      (set! target-exe (string (project-name)"-c")))
-
-     ((equal? target "C2native")
-      (trun "cd src/; make tags")
-      (trun "cd src/; ./etc/make-native.sh --prefix="prefix" "make-config)
-      (trun "cd src/; make check")
-      (trun "cd src/; umask 022; make install")
-      (set! target-exe (project-name)))
-
-     ((equal? target "C2svm")
-      (trun "cd src/; make tags")
-      (trun "cd src/; ./etc/make-native.sh --prefix="prefix" "make-config)
-      (trun "cd src/; make check")
-      (trun "cd src/; umask 022; make install")
-      (set! target-exe (string (project-name)"-svm1")))
-
-     (else
-      (error "Unexpected target:" target)))
-
-    (let ((plugin-errors
-	   (with-subprocess-environment-variable
-	    "MIT_SCHEME_EXE" (string prefix"/bin/"target-exe)
-	    (lambda ()
-	      (reduce + 0
-		      (map (lambda (plugin) (make-install-plugin plugin prefix))
-			   plugin-list))))))
-      (if (not (zero? plugin-errors))
-	  (error "Plugins failed to build:" plugin-errors)))))
+    (cond ((file-directory? ".git")
+	   (make-install-doc prefix))
+	  ((file-directory? "../.git")
+	   (lndir "../doc")
+	   (make-install-doc prefix))
+	  (else
+	   (error "Not a git working directory:"
+		  (working-directory-pathname))))
+
+    (if cross?
+	(let ((config-options
+	       (decorated-string-append
+		"" " " ""
+		(filter (lambda (option)
+			  (not (string-prefix? option "--enable-debugging")))
+			(burst-string make-config #\space #t)))))
+	  (if (not (file-directory? "cross"))
+	      (make-directory "cross"))
+	  (cond ((file-directory? ".git")
+		 (for-each (lambda (name)
+			     (lndir* name "src/" "cross/" "../src"))
+			   (sort string<? (directory-file-names "src"))))
+		((file-directory? "../.git")
+		 (for-each (lambda (name)
+			     (lndir* name "../src/" "cross/" "../../src"))
+			   (directory-file-names "../src")))
+		(else
+		 (error "Unexpected source directory:"
+			(working-directory-pathname))))
+	  (if (not (file-exists? "cross/configure"))
+	      (trun "cd cross/ && ./Setup.sh"))
+	  (if (not (file-exists? "cross/Makefile"))
+	      (trun "cd cross/ && ./configure --prefix="prefix
+		    " --disable-default-plugins"
+		    (if (not (string=? target host-arch))
+			(string-append
+			 " --enable-cross-compiling"
+			 " --enable-native-code="target
+			 " "config-options)
+			(string-append
+			 " "config-options))))
+	  (trun "cd cross/ && make all")))
+
+    (cond ((file-directory? ".git"))
+	  ((file-directory? "../.git")
+	   (lndir "../src"))
+	  (else
+	   (error "Unexpected source directory:"(working-directory-pathname))))
+    (if (not (file-exists? "src/configure"))
+	(trun "cd src/ && ./Setup.sh"))
+    (if (not (file-exists? "src/Makefile"))
+	(trun "cd src/ && ./configure --prefix="prefix
+	      (if (not master?) " --disable-default-plugins" "")
+	      (if cross? " --with-scheme-build=../cross " " ")
+	      make-config))
+    (trun "cd src/ && make tags")
+    (trun "cd src/ && make all")
+    (lndir "../tests")
+    (trun "cd src/ && make check")
+    (trun "cd src/ && umask 022 && make install")
+
+    (if (not master?)
+	(let ((plugin-errors
+	       (with-subprocess-environment-variable
+		"MIT_SCHEME_EXE" (string prefix"/bin/"(project-name))
+		(lambda ()
+		  (reduce + 0
+			  (map (lambda (plugin)
+				 (make-install-plugin plugin prefix master?))
+			       plugin-list))))))
+	  (if (not (zero? plugin-errors))
+	      (error "Plugins failed to build:" plugin-errors))))))
 
 (define (load-make-config)
   (cond ((file-exists? "devops-config.scm")
@@ -890,39 +892,39 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   make-config)
 
 (define (lndir dest)
-  (let ((dirname (dirname dest)))
-    (let loop ((name (filename dest))
-	       (dstdir dirname)
-	       (srcdir "")
-	       (reldir (drop-slash dirname)))
-      (let ((dst (string dstdir name))
-	    (src (string srcdir name)))
-	(let ((dst-atts (file-attributes-direct dst))
-	      (src-atts (file-attributes-direct src)))
-	  (if (eq? #t (file-attributes/type dst-atts))
-	      (if (not (or (eq? #f src-atts)
-			   (eq? #t (file-attributes/type src-atts))))
-		  (warn "not a directory:" src)
-		  (let ((dstdir* (string dst"/"))
-			(srcdir* (string src "/"))
-			(reldir* (string "../"reldir"/"name)))
-		    (if (eq? #f src-atts)
-			(make-directory src))
-		    (for-each
-		      (lambda (name)
-			(cond ((string=? "." name))
-			      ((string=? ".." name))
-			      ((string-suffix? "~" name))
-			      (else (loop name dstdir* srcdir* reldir*))))
-		      (directory-file-names dst))))
-	      (let ((reldirname (string reldir"/"name)))
+  (let ((destdir (dirname dest))
+	(name (filename dest)))
+    (lndir* name destdir "" (drop-slash destdir))))
+
+(define (lndir* name dstdir srcdir reldir)
+  (let ((dst (string dstdir name))
+	(src (string srcdir name)))
+    (let ((dst-atts (file-attributes-direct dst))
+	  (src-atts (file-attributes-direct src)))
+      (if (eq? #t (file-attributes/type dst-atts))
+	  (if (not (or (eq? #f src-atts)
+		       (eq? #t (file-attributes/type src-atts))))
+	      (warn "not a directory:" src)
+	      (let ((dstdir* (string dst"/"))
+		    (srcdir* (string src "/"))
+		    (reldir* (string "../"reldir"/"name)))
 		(if (eq? #f src-atts)
-		    (soft-link-file reldirname src)
-		    (let ((src-type (file-attributes/type src-atts)))
-		      (cond ((not (string? src-type))
-			     (warn "not a symlink:" src))
-			    ((not (string=? src-type reldirname))
-			     (warn "bogus symlink:" src reldirname))))))))))))
+		    (make-directory src))
+		(for-each
+		  (lambda (name)
+		    (cond ((string=? "." name))
+			  ((string=? ".." name))
+			  ((string-suffix? "~" name))
+			  (else (lndir* name dstdir* srcdir* reldir*))))
+		  (directory-file-names dst))))
+	  (let ((reldirname (string reldir"/"name)))
+	    (if (eq? #f src-atts)
+		(soft-link-file reldirname src)
+		(let ((src-type (file-attributes/type src-atts)))
+		  (cond ((not (string? src-type))
+			 (warn "not a symlink:" src))
+			((not (string=? src-type reldirname))
+			 (warn "bogus symlink:" src reldirname))))))))))
 
 (define (make-install-doc prefix)
   (if (not (file-exists? "doc/configure"))
@@ -932,15 +934,22 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (trun "cd doc/; make all")
   (trun "cd doc/; umask 022; make install"))
 
-(define (make-install-plugin plugin prefix)
-  (let ((result (ignore-errors
-		 (lambda () (make-install-plugin* plugin prefix)))))
-    (if (condition? result)
-	(begin
-	  (log "# "(plugin-name plugin)" failed to build:"
-	       " "(condition/report-string result)"\n")
-	  1)
-	0)))
+(define default-plugin-names '("edwin" "imail" "x11" "x11-screen"))
+
+(define (make-install-plugin plugin prefix master?)
+  (if (and master?
+	   (member (plugin-name plugin) default-plugin-names))
+      (begin
+	(log "# "(plugin-name plugin)" skipped default plugin\n")
+	0)
+      (let ((result (ignore-errors
+		     (lambda () (make-install-plugin* plugin prefix)))))
+	(if (condition? result)
+	    (begin
+	      (log "# "(plugin-name plugin)" failed to build:"
+		   " "(condition/report-string result)"\n")
+	      1)
+	    0))))
 
 (define (make-install-plugin* plugin prefix)
   (let ((dir (plugin-directory plugin)))
@@ -1126,39 +1135,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	(cdr entry)
 	(error "Match key not found:" key match))))
 
-(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 (read-first-line filename)
   (call-with-input-file filename
     (lambda (in)
@@ -1187,6 +1163,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	      parent
 	      (loop (drop-slash (dirname pwd))))))))
 
+(define (final-slash? string)
+  (let ((len-1 (fix:-1+ (string-length string))))
+    (and (fix:>= len-1 0)
+	 (char=? #\/ (string-ref string len-1)))))
+
 (define (drop-slash string)
   (let ((len-1 (fix:-1+ (string-length string))))
     (if (and (fix:>= len-1 0)
@@ -1194,6 +1175,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	(string-slice string 0 len-1)
 	string)))
 
+(define (add-slash string)
+  (if (not (final-slash? string))
+      (string-append string "/")))
+
 (define (filename filename)
   (let ((i (string-find-previous-char filename #\/)))
     (if (not i)