zilch/lib/build-chicken-parallel/process.scm

(import (scheme base) (scheme read) (scheme write) (scheme process-context))

(define egg-name (cadr (command-line)))

(define srcdir (caddr (command-line)))
(define outdir (cadr (cddr (command-line))))
(define extra-cflags (cadr (cdr (cddr (command-line)))))
(define extra-ldflags (cadr (cddr (cddr (command-line)))))

(define shared-flags '())
(define link-flags '())
(define installed-files '())

(unless (string=? extra-cflags "") (set! shared-flags (list "-C" extra-cflags)))
(unless (string=? extra-ldflags "") (set! link-flags (list "-L" extra-ldflags)))

; TODO(puck): make this actually escaped
(define (make-escaped-string val) (string-append "'" val "'"))

(define (emit-build outputs implicit-outputs rulename deps implicit-deps flags)
  (write-string "build ")
  (for-each (lambda (output) (write-string " ") (write-string output)) outputs)
  (unless (eq? implicit-outputs '()) (write-string " |"))
  (for-each (lambda (implicit-output) (write-string implicit-output) (write-string " ")) implicit-outputs)
  (write-string ": ")
  (write-string rulename)
  (for-each (lambda (dep) (write-string " ") (write-string dep)) deps)
  (unless (eq? implicit-deps '()) (write-string " |"))
  (for-each (lambda (implicit-dep) (write-string implicit-dep) (write-string " ")) implicit-deps)
  (write-string "\n")
  (for-each (lambda (flag) (write-string "    ") (write-string (symbol->string (car flag))) (write-string " = ") (write-string (cdr flag)) (write-string "\n")) flags))
 

(define counter 1)
(define (inc-ctr)
  (set! counter (+ counter 1))
  (string-append "1980-01-01 00:00:" (number->string counter)))

; Workaround to deal with the non-scheme component dependencies.
(define (is-source-file hdr)
  (unless (string? hdr) (set! hdr (symbol->string hdr)))
  (define len (string-length hdr))
  (string=? (string-copy hdr (- len 2)) ".h"))

(define (process-component component)
  (define name (symbol->string (cadr component)))
  (define source #f)
  (define deps '())
  (define csc-options shared-flags)
  (for-each
   (lambda (v)
    (case (car v)
     ((source) (set! source (cadr v)))
     ((component-dependencies) (set! deps (cdr v)))
     ((csc-options) (set! csc-options (append csc-options (cdr v))))))
   (cddr component))
  
  (define new-deps '())
  (for-each (lambda (d) (unless (is-source-file d) (set! new-deps (cons d new-deps)))) deps)
  (set! deps new-deps)
  
  (define flagobj (list (cons 'unit name)))
  (define flagstr "")
  (unless (eq? csc-options shared-flags)
    (for-each (lambda (f) (set! flagstr (string-append flagstr " " (make-escaped-string f)))) csc-options)
    (set! flagobj (cons (cons 'flags flagstr) flagobj)))

  (emit-build
     (list (string-append name ".so"))
     (list (string-append name ".import.scm"))
     "csc_shared" (list (string-append srcdir source))
     (map (lambda (dep) (string-append (symbol->string dep) ".import.so")) deps)
     (cons (cons 'rnd (inc-ctr)) flagobj))

  (emit-build
     (list (string-append name ".static.o"))
     (list (string-append name ".link"))
     "csc_static" (list (string-append srcdir source))
     (map (lambda (dep) (string-append (symbol->string dep) ".import.so")) deps)
     (cons (cons 'rnd (inc-ctr)) (cons (cons 'linkfile (string-append name ".link")) flagobj)))

  (emit-build
     (list (string-append name ".import.so"))
     '()
     "csc_shared_import" (list (string-append name ".import.scm"))
     '()
     (cons (cons 'rnd (inc-ctr)) flagobj))

  (write-string (string-append "default " name ".so " name ".static.o " name ".import.so\n"))

  (emit-build (list (string-append outdir "/" name ".import.so")) '() "install" (list (string-append name ".import.so")) '() '())
  (emit-build (list (string-append outdir "/" name ".so")) '() "install" (list (string-append name ".so")) '() '())
  (emit-build (list (string-append outdir "/" name ".o")) '() "install" (list (string-append name ".static.o")) '() '())
  (emit-build (list (string-append outdir "/" name ".link")) '() "install" (list (string-append name ".link")) '() '())


  (set! installed-files
      (append installed-files
         (list
          (string-append outdir "/" name ".o")
          (string-append outdir "/" name ".so")
          (string-append outdir "/" name ".link")
          (string-append outdir "/" name ".import.so")))))

(define egg (with-input-from-file (string-append egg-name ".egg") read))

(with-output-to-file "build.ninja"
 (lambda ()
  (display "rule csc_shared
    command = faketime -f \"$rnd\" csc -host -D compiling-extension -regenerate-import-libraries -setup-mode $flags $linkflags -J -shared $in -o $out
    description = CSC $unit (shared)

rule csc_shared_import
    command = faketime -f \"$rnd\" csc -host -setup-mode $flags $linkflags -J -shared $in -o $out
    description = CSC $unit (import)

rule csc_static
    command = faketime -f \"$rnd\" csc -host -D compiling-extension -D compiling-static-extension -regenerate-import-libraries -setup-mode -profile $flags -emit-link-file $linkfile -c -unit $unit -M -static $in -o $out
    description = CSC $unit (static)

rule install
    command = mkdir -p $$(dirname $out) && cp $in $out
    description = INST $in
")
  (for-each
   (lambda (val)
       (when (eq? (car val) 'component-options)
           (for-each
            (lambda (v)
              (when (eq? (car v) 'csc-options)
                    (set! shared-flags `(,@shared-flags ,@(cdr v)))
                    (write-string "flags =")
                    (for-each (lambda (l) (write-string (string-append " " (make-escaped-string l)))) shared-flags)
                    (write-string "\n"))
              (when (eq? (car v) 'link-options)
                    (set! link-flags `(,@link-flags ,@(cdr v)))
                    (write-string "linkflags =")
                    (for-each (lambda (l) (write-string (string-append " " (make-escaped-string l)))) link-flags)
                    (write-string "\n"))) (cdr val)))
       (when (eq? (car val) 'components)
             (for-each (lambda (p) (when (eq? 'extension (car p)) (process-component p))) (cdr val))))
   egg)
  (emit-build (list (string-append outdir "/" egg-name ".egg-info")) '() "install" (list (string-append egg-name ".egg-info")) '() '())
  (set! installed-files (cons (string-append outdir "/" egg-name ".egg-info") installed-files))
  (emit-build '("install") '() "phony" installed-files '() '())))


(define egginfo `((installed-files ,@installed-files) ,@egg))
(with-output-to-file (string-append egg-name ".egg-info") (lambda () (write egginfo)))