@menu
* Project Repository::
* Project Configuration::
+* Debugging Builds::
* Release Process::
* Build Process::
* Lint Detection::
mentions a recent Ubuntu version, the host will build Debian packages.
@end deffn
+@node Debugging Builds
+@section Debugging Builds
+
+A debugging build runs in the working directory of a developer's git
+repository (or shadow thereof) and provides special options to core
+and plugin @code{./configure} scripts (e.g.
+@code{"--enable-debugging"}). The build begins by loading a
+@file{devops-config.scm} file into the @code{(devops)} package where
+it can adjust many aspects of the build. The special options for the
+build are specified by applying @code{make-configuration} to a list of
+strings.
+
+@deffn Procedure make-configuration . options
+@var{Options} should be a list of strings to be passed as arguments to
+the @code{./configure} scripts of the core and plugins.
+@end deffn
+
+An example @file{devops-config.scm} file:
+
+@smallexample
+;; Shared configuration.
+(load (merge-pathnames "devops/config.scm"
+ (current-load-pathname)))
+;; Build-specific configuration.
+(make-configuration "--enable-debugging")
+@end smallexample
+
+If the working directory contains @file{src}, @file{doc} and
+@file{tests} subdirectories it is assumed to contain a core system.
+In this case a @code{--prefix} option is added to the core build
+configuration so that the core is installed in the subdirectories
+@file{bin}, @file{lib} and @file{share}. The test core is built and
+installed first, and is used as the host Scheme for plugin builds and
+installs. There is no inter-plugin dependency analysis currently, so
+plugins are built and installed serially in the order they were
+created.
+
+To accommodate multiple debugging builds, a ``shadow'' of the working
+directory can be created. A shadow directory contains symbolic links
+to the files in a source directory and shadows of its subdirectories,
+much like the shadow directories created by the X11 build utility
+@code{lndir}. If the build starts in a subdirectory of the working
+directory, it will assume the build is intended to run in shadows of
+the working directories. If it does not find a
+@file{devops-config.scm} file in this subdirectory, it will attempt to
+load one from the working directory.
+
+@deffn Procedure devops:make target
+@var{Target} is optional and defaults to @code{native} which specifies
+a core with the same Scheme architecture as the host. It can also be
+the symbol @code{svm} which specifies a core cross-compiled to a
+Scheme virtual machine with the same word size as the host. Plugins,
+unlike the core, are always native to their host Scheme compiler
+@verb{|${MIT_SCHEME_EXE=mit-scheme}|} (as well as their C compiler
+@verb{|${CC=gcc}|}, dynamic linker, etc.).
+
+This procedure is continuable. When restarted it first checks any
+shadow directories for missing or incorrect links, then re-makes and
+re-installs the core (if any) and each plugin in order. Note that
+this does not take into account syntactic dependencies between
+plugins. If a plugin exports syntax and changes how that syntax
+expands, any plugins using the syntax will need to be cleaned (at
+least partially) and re-built.
+@end deffn
+
@node Release Process
@section Release Process
(cond ((equal? arg1 "status") (apply devops:status (cdr cmdl)))
((equal? arg1 "release") (apply devops:release (cdr cmdl)))
((equal? arg1 "build") (apply devops:build (cdr cmdl)))
+ ((equal? arg1 "make") (apply devops:make (cdr cmdl)))
(else (error "Unknown developer operation:" cmdl)))))
(define (devops:status #!optional name)
(deregister-timer-event record)
value))))
\f
+;;;; Make
+
+(define (devops:make target)
+ (if (not (member target '("native" "svm" "C" "C-old" "C2native" "C2svm")))
+ (error "unknown build target:" target))
+ (load-make-config)
+ (%exit
+ (call-with-current-continuation ;throw here to unwind all
+ (lambda (abort-job)
+ (bind-condition-handler (list condition-type:error)
+ (named-lambda (job-error-handler condition)
+ (fresh-line)
+ (log "# "(emacs-friendly-timestamp)"\n")
+ (write-condition-report condition (current-output-port))
+ (newline)
+ (flush-output)
+ (abort-job 2))
+ (lambda ()
+ (with-^G-interrupt-handler
+ (named-lambda (job-^G-interrupt-handler)
+ (abort-job 3))
+ (lambda ()
+ (devops:make* target)
+ 0))))))))
+
+(define (devops:make* target)
+ (let* ((prefix (or (get-environment-variable "PWD")
+ (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))))
+
+ ;;(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 "# 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)))))
+
+(define (load-make-config)
+ (cond ((file-exists? "devops-config.scm")
+ (load "devops-config.scm"))
+ ((file-exists? "../devops-config.scm")
+ (load "../devops-config.scm"))
+ ((let* ((git-root (find-git-root))
+ (file (string git-root"/devops-config.scm")))
+ (and (file-exists? file)
+ (begin (load file)
+ #t))))
+ (else
+ (error "no devops test configuration found"))))
+
+(define make-config "")
+(define (make-configuration . args)
+ (if (not (null? args))
+ (begin
+ (if (not (list-of-type? args string?))
+ (error:wrong-type-argument args "list of strings"
+ 'make-configuration))
+ (set! make-config (decorated-string-append "" " " "" args))))
+ 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)))
+ (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"))
+ (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"))
+
+(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 (make-install-plugin* plugin prefix)
+ (let ((dir (plugin-directory plugin)))
+ (if (not (file-directory? dir))
+ (error "plugin directory not found:" dir))
+ (log "# "dir":\n")
+ (if (not (file-exists? (string dir"/configure")))
+ (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")
+ (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")))))
+
+(define (trun . strings)
+ ;;(log-timestamp)
+ (log "# "(emacs-friendly-timestamp)"\n")
+ (apply run strings))
+
+(define (emacs-friendly-timestamp)
+ (let ((dt (local-decoded-time)))
+ (define (pad num) (string-pad-left (number->string num) 2 #\0))
+ (let ((year (number->string (decoded-time/year dt)))
+ (month (pad (decoded-time/month dt)))
+ (day (pad (decoded-time/day dt)))
+ (hour (pad (decoded-time/hour dt)))
+ (minute (pad (decoded-time/minute dt)))
+ (second (pad (decoded-time/second dt))))
+ (string year"-"month"-"day" "hour"."minute"."second))))
+
+(define (with-^G-interrupt-handler inside-handler thunk)
+ (let ((env (->environment '(runtime interrupt-handler)))
+ (outside-handler))
+ (dynamic-wind
+ (lambda ()
+ (set! outside-handler (environment-lookup env 'hook/^G-interrupt))
+ (environment-assign! env 'hook/^G-interrupt inside-handler))
+ thunk
+ (lambda ()
+ (set! inside-handler (environment-lookup env 'hook/^G-interrupt))
+ (environment-assign! env 'hook/^G-interrupt outside-handler)))))
+\f
;;;; Configuration
(define (project-name #!optional name)
(begin
(write-string line out)
(newline out)
- (loop))))))))
\ No newline at end of file
+ (loop))))))))
+
+(define (find-git-root)
+ (let ((pwd (drop-slash (or (get-environment-variable "PWD")
+ (error "PWD not set")))))
+ (let loop ((parent (drop-slash (dirname pwd))))
+ (if (string-null? parent)
+ (error "no git root found:" pwd)
+ (if (file-directory? (string parent"/.git"))
+ parent
+ (loop (drop-slash (dirname pwd))))))))
+
+(define (drop-slash string)
+ (let ((len-1 (fix:-1+ (string-length string))))
+ (if (and (fix:>= len-1 0)
+ (char=? #\/ (string-ref string len-1)))
+ (string-slice string 0 len-1)
+ string)))
+
+(define (filename filename)
+ (let ((i (string-find-previous-char filename #\/)))
+ (if (not i)
+ filename
+ (string-slice filename (fix:1+ i)))))
+
+(define (dirname filename)
+ (let ((i (string-find-previous-char filename #\/)))
+ (if (not i)
+ ""
+ (string-slice filename 0 (fix:1+ i)))))
+
+(define (basename filename)
+ (let* ((start (let ((i (string-find-previous-char filename #\/)))
+ (if (not i)
+ 0
+ (fix:1+ i))))
+ (end (string-find-next-char filename #\. start)))
+ (if (not end)
+ (if (fix:zero? start)
+ filename
+ (string-slice filename start))
+ (string-slice filename start end))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff