devops: New build procedure for 10.1.

diff --git a/src/devops/build.scm b/src/devops/build.scm
index 2403d61a3b80fa59cecf1b43e3664b685fe85f00..ffe48eabb45cb57cad449d31f3e4d4553b5a984c 100644 (file)
--- 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 c19d097d7bf1748931cf356f1e89fe6214239f1c..03d252fefebe91b0510ecaae1af959b0f0eea5a0 100644 (file)
--- 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)