;;; csm


(import (chicken file))
(import (chicken string))
(import (chicken process-context))
(import (chicken file posix))
(import (chicken pretty-print))
(import (chicken pathname))
(import (chicken sort))
(import (chicken process))
(import (chicken io))
(import (chicken port))
(import (chicken condition))
(import (chicken format))
(import (chicken read-syntax))
(import (chicken platform))
(import (chicken keyword))
(import matchable)
(import srfi-1)
(import srfi-13)
(import srfi-14)
(import miscmacros)

(define version "0.3")

(define-record module-info
  name
  r7rs
  filename
  imports
  dependencies
  option-dependencies
  syntax
  options
  main
  program-dependency)

(define-record c-module-info
  filename
  dependencies
  option-dependencies
  options)

(define-record program-info
  name
  options
  main
  dependencies
  option-dependencies)

(define short-options (string->char-set "smPfiJMNxubgdnhc"))
(define long-options
  '("-d0" "-d1" "-d2" "-O1" "-O2" "-O3" "-O4" "-O5"
    "-explicit-use" "-no-trace" "-no-warnings" "-no-usual-integrations"
    "-optimize-leaf-routines" "-unsafe" "-block" "-disable-interrupts"
    "-fixnum-arithmetic" "-to-stdout" "-profile" "-raw" "-accumulate-profile"
    "-check-syntax" "-case-insensitive" "-shared" "-compile-syntax"
    "-no-lambda-info" "-dynamic" "-disable-stack-overflow-checks" "-local"
    "-emit-external-prototypes-first" "-inline" "-release"
    "-analyze-only" "-keep-shadowed-macros" "-inline-global" "-ignore-repository"
    "-no-symbol-escape" "-no-parentheses-synonyms" "-r5rs-syntax"
    "-no-argc-checks" "-no-bound-checks" "-no-procedure-checks" "-no-compiler-syntax"
    "-emit-all-import-libraries" "-no-elevation" "-module-registration"
    "-no-module-registration" "-no-procedure-checks-for-usual-bindings"
    "-regenerate-import-libraries" "-specialize" "-strict-types" "-clustering"
    "-lfa2" "-debug-info" "-no-procedure-checks-for-toplevel-bindings"))
(define arg-options
  '("-debug" "-heap-size" "-nursery" "-stack-size" "-compiler" "-unit" "-uses"
    "-keyword-style" "-optimize-level" "-include-path" "-database-size" "-extend"
    "-prelude" "-postlude" "-prologue" "-epilogue" "-emit-link-file"
    "-inline-limit" "-profile-name" "-unroll-limit" "-emit-inline-file"
    "-consult-inline-file" "-emit-types-file" "-consult-types-file"
    "-debug-level" "-emit-import-library" "-module" "-link" "-C" "-L" "-I"))

(define include-path ##sys#include-pathnames)
(define compile-import-libs #f)
(define mode 'compile)
(define verbose #f)
(define programs '())
(define dry-run #f)
(define *mod* #f)
(define *functor-params* '())
(define *r7rs* #f)
(define *imports* #f)
(define *fname* #f)
(define *for-syntax* #f)
(define *options* '())
(define *static* #f)
(define *deps* '())
(define *prefix* '())
(define *option-deps* '())
(define *ignored* '())
(define *ctxt* #f)
(define dependencies '())
(define syntax-modules '())
(define modules '())
(define c-modules '())
(define *depth* "")
(define makefile "Makefile")
(define root (current-directory))
(define debug #f)
(define *program-options* '())
(define *main* #f)
(define max-procs 1)

(define scheme-extensions '("scm" "ss" "sch" "scheme" "r4rs" "r5rs" "r7rs" "sld"))

(cond-expand
  (csi
    (define csc "csc")
    (define csi "csi"))
  (else
    (import (chicken foreign))
    (define default-bindir (foreign-value "C_INSTALL_BIN_HOME" c-string))
    (define csc
      (string-append default-bindir "/" (foreign-value "C_CSC_PROGRAM" c-string)))
    (define csi
      (string-append default-bindir "/" (foreign-value "C_CSI_PROGRAM" c-string)))))

(define (read-source fname prefix r7rs)
  (fluid-let ((*mod* #f)
              (*functor-params* '())
              (*fname* (path fname prefix))
              (*prefix* prefix)
              (*r7rs* r7rs)
              (*imports* '())
              (*deps* *deps*)
              (*option-deps* *option-deps*)
              (*ctxt* fname))
    (scan-source-file fname)))

(define (scan-source-file fname)
  (dribble "scanning ~a" fname)
  (with-input-from-file fname
    (lambda ()
      (let loop ()
        (let ((x (read-safe fname)))
          (cond ((eof-object? x)
                  (and *mod*
                       (not (find-module *mod*))
                       (begin
                         (dribble "registering module ~a, file ~s, options: ~s"
                            *mod* *fname* *options*)
                         #t)
                       (push! (make-module-info
                                *mod* *r7rs* *fname* *imports*
                                *deps* *option-deps* #f *options* #f #f)
                             modules)))
                (else
                  (scan-form x)
                  (loop))))))))

(define (canonical-name x)
  (if (list? x)
      (string-intersperse (map ->string x) ".")
      (->string x)))

(define (scan-form x)
  (match x
    (('cond-expand clauses ...)
      (scan-form `(begin ,@(scan-cond-expand clauses))))
    (('functor (name (fparams _) ...) . body)
      (when *mod* (fail "multiple module definitions in file ~a" *ctxt*))
      (set! *functor-params* (map ->string fparams))
      (set! *mod* (canonical-name name))
      (scan-form `(begin ,@body)))
    (('module name '=  (fname fparams ...))
      (when *mod* (fail "multiple module definitions in file ~a" *ctxt*))
      (set! *mod* (canonical-name name))
      (scan-import fname)
      (map scan-import fparams))
    ((or ('module name _ . body)
         ('module name '=  _ . body))
      (when *mod* (fail "multiple module definitions in file ~a" *ctxt*))
      (set! *mod* (canonical-name name))
      (scan-form `(begin ,@body)))
    (('define-library name . body)
      (when *mod* (fail "multiple library definitions in file ~a" *ctxt*))
      (set! *mod* (canonical-name name))
      (set! *r7rs* #t)
      (scan-form `(begin ,@body)))
    (((or 'begin 'begin0) . body)
      (for-each scan-form body))
    (('begin-for-syntax . body)
      (fluid-let ((*for-syntax* #t))
        (for-each scan-form body)))
    (('include fname0 fnames ...)
      (when (or *r7rs* (null? fnames))
        (scan-include-files (cons fname0 fnames))))
    (((or 'bind-file 'bind-file*) fname)
      (add-dependency *fname* fname))
    (('include-library-declarations fnames ...)
      (when *r7rs* (scan-include-files fnames)))
    (('include-ci fnames ...)
      (when *r7rs*
        (parameterize ((case-sensitive #f))
          (scan-include-files fnames))))
    (('include-relative fname)
      (scan-include-files (list (make-pathname (pathname-directory *fname*) fname))))
    (('import . imps)
      (for-each scan-import imps))
    (((or 'import-for-syntax 'import-syntax-for-syntax) . imps)
      (for-each (cut scan-import <> #t) imps))
    (_ #f)))

(define (scan-cond-expand clauses)
  (define (check f)
    (match f
      (('and fs ...) (every check fs))
      (('or fs ...) (any check fs))
      (('not f) (not (check f)))
      (x (and (symbol? x) (keyword? x) (feature? f)))))
  (let loop ((clauses clauses))
    (match clauses
      (() (fail "(~a) no suitable clause in `cond-expand' found" *fname*))
      ((('else . body) . _) body)
      (((chk . body) . clauses)
        (if (check chk)
            body
            (loop clauses)))
      (_ (fprintf (current-error-port) "Warning: (~a) malformed `cond-expand'"
             *fname*)))))

(define (find-include fname)
  (if (string-prefix? "/" fname)
      fname
      (let loop ((pns include-path))
        (cond ((null? pns)
                (fprintf (current-error-port)
                  "Warning: (~a) included file ~s not found\n" *fname* fname)
                #f)
              ((file-exists? (make-pathname (car pns) fname))
               => (lambda (fn) fn))
              (else (loop (cdr pns)))))))

(define (scan-include-files fnames)
  (for-each
    (lambda (fname)
      (let ((fname (find-include fname)))
        (when fname
          (add-dependency *fname* (normalize fname))
          (scan-source-file fname))))
    fnames))

(define (scan-import imp #!optional (syntax *for-syntax*))
  (match imp
    (((or 'only 'prefix 'except 'rename) imp . _)
      (scan-import imp))
    (_ (let ((name (canonical-name imp)))
         (unless (or (member name *functor-params* string=)
                     (and *mod* (string= name *mod*)))
           (push! name *imports*)
           (when syntax (mark-syntax-module name)))))))

(define (path fname #!optional prefix)
  (cond ((string-prefix? "/" fname) fname)
        ((and prefix (not (null? prefix)))
          (string-intersperse (append prefix (list fname)) "/"))
        (else fname)))

(define (walk-directory dir prefix proc)
  (let walk ((here dir) (prefix prefix))
    (let ((fs (directory here)))
      (fluid-let ((*options* *options*)
                  (*ignored* *ignored*)
                  (*deps* *deps*)
                  (*option-deps* *option-deps*)
                  (*depth* (string-append *depth* " ")))
        (set! *options*
          (append *options* (read-options-file (path "all.options" prefix))))
        (for-each
          (lambda (f)
            (let ((fn (path f prefix)))
              (if (or (member f '(".git" ".svn" "CVS" ".hg"))
                      (string-suffix? ".import.scm" fn)
                      (member (normalize fn) *ignored*))
                (dribble "ignoring ~a" fn)
                (if (directory? fn)
                    (walk fn (append prefix (list f)))
                    (proc fn prefix)))))
          fs)))))

(define (dribble fstr . args)
  (cond (debug
          (display *depth* (current-error-port))
          (apply fprintf (current-error-port) fstr args)
          (newline (current-error-port))
          #t)
        (else #f)))

(define (explain fstr . args)
  (when verbose
    (apply fprintf (current-error-port) fstr args)
    (newline (current-error-port)))
  #t)

(define (process-files dir)
  (explain "root directory is ~a" (or dir (current-directory)))
  (walk-directory (or dir ".") (if dir (list dir) '())
    (lambda (fname prefix)
      (let ((ext (pathname-extension fname)))
        (fluid-let ((*options* *options*)
                    (*deps* *deps*)
                    (*option-deps* *option-deps*))
          (cond ((member ext scheme-extensions)
                 (set! *options* (append *options* (file-specific-options fname)))
                 (read-source fname prefix (member ext '("sld" "r7rs"))))
                ((and (member ext '("c" "cpp" "cxx"))
                      (not (file-exists? (pathname-replace-extension fname "scm"))))
                 (dribble "walk: ~a" fname)
                 (push! (make-c-module-info
                          fname
                          *deps*
                          *option-deps*
                          (append *options* (file-specific-options fname)))
                        c-modules))))))))

(define (file-specific-options fname)
  (read-options-file (pathname-replace-extension fname "options")))

(define (program-specific-options fname)
  (append (read-options-file (make-pathname root "all.options"))
          (read-options-file (make-pathname root fname "options"))))

(define (read-options-file of)
  (cond ((file-exists? of)
          (dribble "reading options file ~a" of)
          (push! of *option-deps*)
          (filter-options (read-options of) (pathname-directory of)))
        (else '())))

(define (mark-syntax-module name)
  (push! name syntax-modules))

(define (add-dependency fname fdep)
  (dribble "adding dependency for ~a: ~a" fname fdep)
  (cond ((assoc fname dependencies) =>
          (lambda (a) (set-cdr! a (cons fdep (cdr a)))))
        (else (push! (list fname fdep) dependencies))))

(define (all-dependencies fname)
  (cons fname
        (cond ((assoc fname dependencies) =>
                (lambda (a)
                  (append-map all-dependencies (cdr a))))
              (else '()))))

(define (all-imports mname)
  (define (collect mname)
    (let ((m (find-module mname)))
      (if (and m (not (module-info-syntax m)))
          (cons mname (append-map collect (module-info-imports m)))
          '())))
  (delete-duplicates
    (append-map collect (module-info-imports (find-module mname)))
    string=?))

(define (fixup-modules)
  (for-each
    (lambda (m)
      (let ((name (module-info-name m)))
        (when (member name syntax-modules)
          (dribble "module ~a is a syntax module" name)
          (module-info-syntax-set! m #t))
        (cond ((assoc (module-info-filename m) dependencies) =>
                (lambda (a)
                  (module-info-dependencies-set! m
                    (delete-duplicates
                      (apply lset-adjoin string=? (module-info-dependencies m)
                        (append-map all-dependencies (cdr a)))
                      string=?)))))))
    modules)
  (for-each
    (lambda (prg)
      (fluid-let ((*main* (program-info-main prg))
                  (*deps* '())
                  (*option-deps* '()))
        (let ((name (program-info-name prg)))
          (dribble "program: ~a" name)
          (program-info-options-set! prg
            (append (program-info-options prg)
                    (program-specific-options name)))
          (program-info-main-set! prg *main*)
          (let* ((main (program-info-main prg))
                 (mm (find-module main)))
            (unless mm (fail "main module for program ~a does not exist" main name))
            (dribble "main module for program ~a is ~a" name main)
            (program-info-dependencies-set! prg *deps*)
            (program-info-option-dependencies-set! prg *option-deps*)
            (for-each
               (lambda (mname)
                (dribble "~a is a program dependency for ~a" mname name)
                (let ((m (find-module mname)))
                  (when (module-info-syntax m)
                    (fail "module ~a can not be a syntax module and a program dependency at the same time"
                          mname))
                  (module-info-program-dependency-set! m #t)))
              (program-imports main))
            (module-info-main-set! mm #t)))))
    programs))

(define (program-imports mname)
  (let ((m (find-module mname)))
    (if *static*
        (all-imports mname)
        (filter-map
          (lambda (mn)
            (and (find-module mn) mn))
          (module-info-imports m)))))

(define (find-c-module name)
  (let ((name (pathname-file name)))
    (find (lambda (cm)
            (string=? (pathname-file (c-module-info-filename cm)) name))
          c-modules)))

(define (to-levels tree topo cmp)
  (define (depends-on? elem level)
    (any (lambda (lvl)
           (let ((adj-list-of-a (assoc elem tree cmp)))
             (and adj-list-of-a (member lvl adj-list-of-a))))
         level))
  (let loop ((topo (reverse topo)) (levs '()))
    (match (cons topo levs)
      [(() . _)
       levs]
      [((curr . next) . ())
       (loop next (list (list curr)))]
      [((curr . next) . (x . y))
       (let lvl-loop ((seen-lvl '())
                      (cand-lvl '())
                      (curr-lvl x)
                      (next-lvl y))
         (if (depends-on? curr curr-lvl)
           (loop next
                 (append seen-lvl
                         (cons (cons curr cand-lvl)
                               (cons curr-lvl next-lvl))))
           (if (null? next-lvl)
             (loop next
                   (append seen-lvl
                           (list cand-lvl)
                           (list (cons curr curr-lvl))))

             (lvl-loop
               (append seen-lvl (if (null? cand-lvl) '() (list cand-lvl)))
               curr-lvl
               (car next-lvl)
               (cdr next-lvl)))))])))

(cond-expand
  (windows
    (define (bfork p) (p))
    (define (bjoin _) (values #f #f 0)))
  (else
    (define bfork process-fork)
    (define bjoin process-wait)))

(define (spawn levels fun)
  (define (make-level lvl)
    (match (length lvl)
      [1
       (fun (car lvl))]
      [n
        (let ((slots (min n max-procs)))
          (let loop ((idx 0) (chunk lvl) (pids '()))
            (if (or (null? chunk) (eq? idx slots))
              (begin
                (for-each
                  (lambda (x)
                    (let-values (((pid succ rc) (bjoin x)))
                      (unless (eq? 0 rc) (exit 1))
                      succ))
                  pids)
                (unless (null? chunk) (loop 0 chunk '())))
              (let ((pid (bfork (lambda () (fun (car chunk))))))
                (loop (+ 1 idx) (cdr chunk) (cons pid pids))))))]))
  (for-each make-level levels))

(define (build-system)
  (explain "building system")
  (for-each build-c-module c-modules)
  (let* ((tree (map (lambda (m)
                      (cons (module-info-name m)
                            (module-info-imports m)))
                    modules))
         (ms (topological-sort tree string=?))
         (levs (reverse (to-levels tree ms string=?))))
    (when (dribble "dependency tree:")
      (pp tree (current-error-port)))
    (when (dribble "build order:")
      (pp levs (current-error-port)))
    (spawn levs
           (lambda (name)
             (let ((m (find-module name)))
               (when (and m (not (module-info-main m)))
                 (build-module m))))))
    (for-each
     build-program
     programs))

(define (generate-makefile)
  (explain "generating makefile ~a" makefile)
  (when (null? programs)
    (fail "need program targets to build makefile"))
  (with-output-to-file makefile
    (lambda ()
      (printf "# GENERATED BY csm ~a\n\n.SUFFIXES:\n.PHONY: all clean\n\nall: ~a\n"
        version
        (join (map (lambda (m) (program-info-name m)) programs)))
      (print "\nclean:\n\trm -f *.import.scm *.so")
      (for-each
        (lambda (prg)
          (let* ((main (program-info-main prg))
                 (name (program-info-name prg))
                 (mm (find-module main))
                 (adeps (join (filter-c-deps (program-info-dependencies prg) #t)))
                 (cdeps (join (filter-c-deps (program-info-dependencies prg))))
                 (pdeps (join (program-info-option-dependencies prg))))
            (printf "\n~a: ~a ~a ~a ~a\n\t~a ~a ~a\n"
              (program-info-name prg)
              (module-info-filename (find-module main))
              (join
                (map (lambda (imp)
                       (target-name (find-module imp)))
                     (program-imports main)))
              adeps
              pdeps
              csc
              (build-cmd (program-build-options prg))
              cdeps)))
        programs)
      (for-each
        (lambda (m)
          (unless (module-info-main m)
            (let ((name (module-info-name m)))
              (printf "\n~a: ~a" (target-name m) (module-info-filename m))
              (for-each
                (lambda (imp)
                  (when (find-module imp)
                    (printf " ~a" (target-name (find-module imp)))))
                (module-info-imports m))
              (for-each
                (lambda (dep) (printf " ~a" dep))
                (module-info-dependencies m))
              (printf "\n\t~a ~a\n"
                 csc
                 (build-cmd (module-build-options m)))
              (when compile-import-libs
                (printf "\n~a.import.so: ~a.import.scm\n" name name)
                (printf "\t~a ~a\n"
                   csc
                   (build-cmd (module-import-build-options m)))))))
        modules)
      (for-each
        (lambda (cm)
          (let ((oname (c-object-name cm)))
            (printf "\n~a: ~a\n\t~a ~a\n"
              oname (c-module-info-filename cm)
              csc (build-cmd (c-module-build-options cm)))))
        c-modules)
      (print "\n# END OF FILE"))))

(define (generate-static-makefile)
  (explain "generating static makefile ~a" makefile)
  (when (null? programs)
    (fail "need program targets to build makefile"))
  (with-output-to-file makefile
    (lambda ()
      (printf "# GENERATED BY csm\n\n.SUFFIXES:\n.PHONY: all clean\n\nall: ~a\n"
        (join
          (map (lambda (m) (program-info-name m)) programs)))
      (printf "\nclean:\n\trm -f ~a *.import.scm *.o *.so\n"
        (join (map program-info-name programs)))
      (for-each
        (lambda (prg)
          (let* ((main (program-info-main prg))
                 (name (program-info-name prg))
                 (mm (find-module main))
                 (adeps (join (filter-c-deps (program-info-dependencies prg) #t)))
                 (cdeps (join (filter-c-deps (program-info-dependencies prg))))
                 (pdeps (join (program-info-option-dependencies prg)))
                 (mdeps (join (module-info-dependencies mm)))
                 (ideps (join (map (lambda (imp)
                                     (target-name (find-module imp)))
                                   (program-imports main)))))
            (printf "\n~a: ~a ~a ~a ~a ~a\n\t~a ~a ~a\n"
              (program-info-name prg)
              (module-info-filename (find-module main))
              ideps pdeps adeps mdeps
              csc
              (build-cmd (program-build-options prg))
              cdeps)))
         programs)
      (for-each
        (lambda (m)
          (unless (module-info-main m)
            (let ((name (module-info-name m)))
              (printf "\n~a: ~a" (target-name m) (module-info-filename m))
              (for-each
                (lambda (imp)
                  (when (find-module imp)
                    (printf " ~a" (target-name (find-module imp)))))
                (module-info-imports m))
              (for-each
                (lambda (dep) (printf " ~a" dep))
                (module-info-dependencies m))
              (printf "\n\t~a ~a\n"
                 csc
                 (build-cmd (module-build-options m)))
              (when compile-import-libs
                (printf "\n~a.import.so: ~a ~a.import.scm\n"
                  name
                  (target-name m)
                  name)
                (printf "\t~a ~a\n"
                   csc
                   (build-cmd (module-import-build-options m)))))))
        modules)
      (for-each
        (lambda (cm)
          (let ((oname (c-object-name cm)))
            (printf "\n~a: ~a\n\t~a ~a\n"
              oname (c-module-info-filename cm)
              csc (build-cmd (c-module-build-options cm)))))
        c-modules)
      (print "\n# END OF FILE"))))

(define (filter-c-deps deps #!optional keep-others)
  (filter-map
      (lambda (d)
        (let* ((cm (find-c-module d)))
          (cond (cm (c-object-name cm))
                (keep-others d)
                (else #f))))
      deps))

(define (c-object-name cm)
  (string-append (pathname-file (c-module-info-filename cm)) ".o"))

(define (find-module name)
  (find (lambda (m) (string=? name (module-info-name m))) modules))

(define (build-module m)
  (let* ((src (module-info-filename m))
         (deps (cons src (module-info-dependencies m)))
         (odeps (module-info-option-dependencies m))
         (name (module-info-name m))
         (target (target-name m)))
    (dribble "checking module ~a" name)
    (dribble " ~a -> ~a" target (join deps))
    (when (check-rebuild target (append deps odeps))
      (compile-module m))))

(define (build-program prg)
  (let* ((main (program-info-main prg))
         (name (program-info-name prg))
         (mm (find-module main))
         (src (module-info-filename mm))
         (deps (cons src (module-info-dependencies mm)))
         (odeps (module-info-option-dependencies mm))
         (pdeps (program-info-dependencies prg))
         (podeps (program-info-option-dependencies prg))
         (ideps (map (cut string-append <> ".o") (program-imports main)))
         (options (if (module-info-r7rs mm)
                      '(-X r7rs -R r7rs)
                      '())))
    (explain "checking program ~a" name)
    (when (check-rebuild name (append deps odeps ideps podeps pdeps))
      (dribble "building program ~a" name)
      (compile (program-build-options prg)))))

(define (check-rebuild target deps)
  (or (and (not (file-exists? target))
                (explain "rebuilding ~a because it does not exist" target))
      (let ((tt (file-modification-time target)))
        (any (lambda (fn)
              (and (file-exists? fn)
                   (> (file-modification-time fn) tt)
                   (explain "rebuilding ~a because ~a changed" target fn)))
             deps))))

(define (build-c-module m)
  (let* ((src (c-module-info-filename m))
         (deps (cons src (c-module-info-dependencies m)))
         (odeps (c-module-info-option-dependencies m))
         (options (c-module-info-options m))
         (target (string-append (pathname-file src) ".o")))
    (explain "checking C module ~a" target)
    (dribble " ~a -> ~a" target (join deps))
    (when (or (and (not (file-exists? target))
                   (explain "rebuilding ~a because it does not exist" target))
              (let ((tt (file-modification-time target)))
                (any (lambda (fn)
                       (and (file-exists? fn)
                            (> (file-modification-time fn) tt)
                            (explain "rebuilding ~a because ~a changed" target fn)))
                     (append deps odeps))))
      (compile-c-module m))))

(define (filter-options opts dir)
  (let loop ((opts opts))
    (match opts
      (() '())
      (("-ignore" fname . more)
        (push! (normalize fname dir) *ignored*)
        (loop more))
      (("-depends" fname . more)
        (push! (normalize fname dir) *deps*)
        (loop more))
      (("-main" mod . more)
        (set! *main* mod)
        (loop more))
      (("-program" prg . more)
        (unless (find-program prg)
          (dribble "registering program ~a - options: ~s" prg *options*)
          (push! (make-program-info prg *options* prg '() '()) programs))
        (loop more))
      (("-static" . more)
        (unless *static* (register-feature! #:csm-static))
        (set! *static* #t)
        (loop more))
      (("-I" fn . more)
        (set! include-path (cons fn include-path))
        (cons* "-I" fn (loop more)))
      (("-C" arg . more)
        (cons* (car opts) arg (loop more)))
      (((or "-ld" "-L") arg . more)
        (set! *program-options* (append *program-options* (list (car opts) arg)))
        (cons* (car opts) arg (loop more)))
      (("-csm-extend" fn . more)
        (load fn)
        (loop more))
      ((opt . more)
        (cond ((or (string-prefix? "-L" opt)
                   (string-prefix? "-Wl," opt))
                 (set! *program-options*
                       (append *program-options* (list (car opts)))))
              (else
                (canonical-option
                  (cons opt more)
                  (lambda (opt more)
                    (append opt (loop more))))))))))

(define (find-program name)
  (find (lambda (prg)
            (string=? name (program-info-name prg)))
          programs))

(define (read-safe ctxt #!optional (in (current-input-port)))
  (handle-exceptions exn
    (begin
      (fprintf (current-error-port) "while reading file ~a:\n" ctxt)
      (print-error-message exn (current-error-port))
      (exit 1))
    (read in)))

(define (read-options fname)
  (with-input-from-file fname
    (lambda ()
      (let loop ((opts '()))
        (match (read-safe fname)
          ((? eof-object?) (reverse opts))
          (((opts ...) . more)
            (loop (append opts more)))
          (('cond-expand clauses ...)
            (loop (append-reverse (scan-cond-expand clauses) opts)))
          (x (loop (cons (->string x) opts))))))))

(define (compile-module m)
  (let* ((name (module-info-name m))
         (mo (module-build-options m))
         (io (module-import-build-options m)))
    (dribble "building module ~a" name)
    (compile mo)
    (when compile-import-libs
      (let* ((implib (string-append name ".import.scm"))
             (implibc (string-append name ".import.so")))
        (when (or (not (file-exists? implibc))
                  (> (file-modification-time implib)
                     (file-modification-time implibc)))
          (compile io))))))

(define (compile-c-module m)
  (compile (c-module-build-options m)))

(define (module-build-options m)
  (let ((options (module-info-options m))
        (src (module-info-filename m))
        (name (module-info-name m))
        (cdeps (filter-c-deps (module-info-dependencies m))))
    (cond ((static-module? m)
             (let ((uses (filter (lambda (name)
                                   (and-let* ((m2 (find-module name)))
                                     (not (module-info-syntax m2))))
                           (module-info-imports m))))
               `(-c -static -J ,src "-I" ,root "-C" "-I" "-C" ,root
                ,@(if (module-info-r7rs m) '(-X r7rs -R r7rs -M) '())
                ,@(if (module-info-main m)
                      '(-N)
                      `(-unit ,name))
                -emit-link-file ,(string-append (module-info-name m) ".link")
                -o ,(target-name m)
                ,@cdeps
                ,@(append-map (lambda (u) (list '-uses u)) uses)
                ,@options)))
          ((module-info-main m)
            `(-N "-I" ,root "-C" "-I" "-C" ,root
             ,@(if (module-info-r7rs m) '(-X r7rs -R r7rs -M) '())
             ,@cdeps))
          ((module-info-program-dependency m)
             (let ((uses (filter (lambda (name)
                                   (and-let* ((m2 (find-module name)))
                                     (not (module-info-syntax m2))))
                           (module-info-imports m))))
               `(-c -J ,src "-I" ,root "-C" "-I" "-C" ,root
                 ,@(if (module-info-r7rs m) '(-X r7rs -R r7rs) '())
                 -unit ,name
                 -o ,(target-name m)
                 ,@(if *static*
                       (append-map (lambda (u) (list '-uses u)) uses)
                       '())
                 ,@cdeps
                 ,@options)))
          (else `(-s -J "-I" ,root "-C" "-I" "-C" ,root
                  ,@(if (module-info-r7rs m) '(-X r7rs -R r7rs) '())
                  ,src -o ,(target-name m) ,@cdeps ,@options)))))

(define (c-module-build-options m)
  (let ((options (c-module-info-options m))
        (src (c-module-info-filename m)))
    (when (member (pathname-extension src) '("cpp" "cxx"))
      (push! "-c++" options))
    (if *static*
        `(-c "-I" ,root "-C" "-I" "-C" ,root
          ,src -o ,(string-append (pathname-file src) ".o")
          ,@options)
        `(-c -s "-I" ,root "-C" "-I" "-C" ,root
          ,src -o ,(c-object-name m) ,@options))))

(define (module-import-build-options m)
  (let* ((name (module-info-name m))
         (implib (string-append name ".import.scm"))
         (implibc (string-append name ".import.so")))
    `(-s -O3 -d0 ,implib -o ,implibc)))

(define (program-build-options prg)
  (let* ((name (program-info-name prg))
         (main (program-info-main prg))
         (pdeps (program-info-dependencies prg))
         (mm (find-module main)))
    `(-o ,name
      "-I" ,root "-C" "-I" "-C" ,root
      ,@(if (module-info-r7rs mm) '(-X r7rs -R r7rs) '())
      ,@(if *static* '(-static) '())
      ,@(filter-map
          (lambda (mname)
            (let ((m (find-module mname)))
              (and (not (module-info-syntax m))
                   (target-name m))))
          (program-imports main))
      ,@(append-map
          (lambda (mname)
            (let ((m (find-module mname)))
              (if (not (module-info-syntax m))
                  `(-uses ,mname)
                  '())))
          (program-imports main))
      ,(module-info-filename mm)
      ,@(filter-map
          (lambda (d)
            (and-let* ((cm (find-c-module d)))
              (c-object-name cm)))
          pdeps)
      ,@(program-info-options prg))))

(define (build-cmd lst)
  (join (map qss lst)))

(define (static-module? m)
  (and *static* (not (module-info-syntax m))))

(define (target-name m)
   (if (or (static-module? m) (module-info-program-dependency m))
       (string-append (module-info-name m) ".o")
       (string-append (module-info-name m) ".so")))

(define (qss x) (qs (->string x)))

(define (compile args)
  (let ((cmd (build-cmd (cons csc args))))
    (print "  " cmd)
    (unless dry-run
      (unless (zero? (system cmd))
        (fail "command failed with non-zero exit status: ~a" cmd)))))

(define (clean-files)
  (let ((files '()))
    (for-each
      (lambda (m)
        (let ((name (module-info-name m)))
          (push! (target-name m) files)
          (push! (string-append name ".import.scm") files)
          (push! (string-append name ".link") files)))
      modules)
    (for-each
      (lambda (m)
        (let ((name (c-module-info-filename m)))
          (push! (string-append (pathname-file name) ".o") files)))
      c-modules)
    (for-each
      (lambda (prg)
        (let ((name (program-info-name prg)))
          (push! (program-info-name prg) files)
          (when *static* (push! (string-append name ".link") files))))
      programs)
    (let ((xfiles (directory ".")))
      (for-each
        (lambda (f)
          (dribble "removing file ~a" f)
          (unless dry-run (delete-file* f)))
        (lset-intersection string=? files xfiles)))))

(define (dump-depends)
  (for-each
    (lambda (m)
      (printf "~a: ~a ~a ~a\n"
        (target-name m)
        (join (module-info-dependencies m))
        (join (map (o target-name find-module)
                   (all-imports (module-info-name m))))
        (join (module-info-option-dependencies m))))
    modules)
  (for-each
    (lambda (m)
      (printf "~a.o: ~a ~a\n"
        (pathname-file (c-module-info-filename m))
        (join (c-module-info-dependencies m))
        (join (c-module-info-option-dependencies m))))
    c-modules)
  (for-each
    (lambda (prg)
      (printf "~a: ~a ~a\n"
        (program-info-name prg)
        (join (map (o target-name find-module)
                   (program-imports (program-info-main prg))))
        (join (program-info-option-dependencies prg))))
    programs))

(define (join lst)
  (string-intersperse lst " "))

(define (canonical-option lst k)
  (match lst
    ((opt . more)
      (cond ((and (member opt arg-options) (pair? more))
              (k (list opt (car more))
                 (cdr more)))
            ((member opt long-options)
              (k (list opt) more))
            ((string-every (cut char-set-contains? short-options <>)
                           (substring opt 1))
              (k '()
                 (append (map (cut string #\- <>)
                              (string->list (substring opt 1)))
                         more)))
            (else (k (list opt) more))))))

(define (parse-arguments args)
  (fluid-let ((*options* '())
              (*static* #f))
    (let loop ((args args))
      (match args
        (()
          (set! include-path (cons (current-directory) include-path))
          (process-files root)
          (fixup-modules)
          (case mode
            ((make)
              (if *static*
                  (generate-static-makefile)
                  (generate-makefile)))
            ((scan) (exit))
            ((clean) (clean-files))
            ((depends) (dump-depends))
            (else (build-system))))
        (((or "-h" "-help" "--help") . _) (usage 0))
        (("-r7rs" . more)
          (set! *r7rs* #t)
          (loop more))
        (("-n" . more)
          (set! dry-run #t)
          (loop more))
        (((or "-C" "-L") opt . more)
          (set! *options* (append *options* (list (car args) opt)))
          (loop more))
        (("-static" . more)
          (set! *static* #t)
          (register-feature! #:csm-static)
          (loop more))
        (("-depends" fname . more)
          (push! fname *deps*)
          (loop more))
        (("-program" prg . more)
          (dribble "registering program ~a - options: ~s" prg *options*)
          (push! (make-program-info prg *options* prg '() '()) programs)
          (loop more))
        (("-ignore" fname . more)
          (push! (normalize fname) *ignored*)
          (loop more))
        (("-d" . more)
          (set! debug #t)
          (loop more))
        (("-o" prg . more)
          (set! program prg)
          (loop more))
        (("-main" mod . more)
          (set! *main* mod)
          (loop more))
        (("-x" . more)
          (set! verbose #t)
          (loop more))
        (("-g" . more)
          (set! mode 'make)
          (loop more))
        (((or "-feature" "-D") f . more)
          (register-feature! f)
          (set! *options (append *options* `(-feature ,f)))
          (loop more))
        (("-no-feature" f . more)
          (unregister-feature! f)
          (set! *options (append *options* `(-no-feature ,f)))
          (loop more))
        (("-I" fn . more)
          (set! include-path (cons (normalize fn) include-path))
          (loop more))
        (("-compile-imports" . more)
          (set! compile-import-libs #t)
          (loop more))
        (("-csm-extend" fn . more)
          (load fn)
          (loop more))
        (("-makefile" name . more)
          (set! mode 'make)
          (set! makefile name)
          (loop more))
        (("-scan" . more)
          (set! mode 'scan)
          (loop more))
        (("-dd" . more)
          (set! mode 'depends)
          (loop more))
        (("-clean" . more)
          (set! mode 'clean)
          (loop more))
        (((or "-j" "-max-procs") num . more)
          (let ((n (string->number num)))
            (unless (and n (> n 0))
              (fail "-max-procs expects a positive integer: ~a given" num))
            (set! max-procs n))
          (loop more))
        ((opt . more)
          (cond ((string-prefix? "-" opt)
                  (canonical-option
                    (cons opt more)
                    (lambda (opt more)
                      (set! *options* (append *options* opt))
                      (loop more))))
                ((directory? opt)
                  (push! (current-directory) *ignored*)
                  (set! root (normalize opt))
                  (loop more))
                (else (fail "unknown option: ~a" opt))))))))

(define (normalize str #!optional dir)
  (unless (string-prefix? "/" str)
    (set! str (string-append (or dir (current-directory)) "/" str)))
  (string-append
    "/"
    (string-intersperse
      (let loop ((parts (string-split str "/")))
        (match parts
          (() '())
          ((_ ".." . more) (loop more))
          (("." . more) (loop more))
          ((part . more) (cons part (loop more)))))
      "/")))

(define (fail fstr . args)
  (apply fprintf (current-error-port) fstr args)
  (newline (current-error-port))
  (exit 1))

(define (usage #!optional (code 1))
  (fprintf (current-error-port) "usage: csm [-help] [-n] [-d] [-static] [-r7rs] [-depends FILENAME] [-ignore FILENAME] [-main MODULE] [-program NAME] [-D FEATURE] [-scan] [-clean] [-dd] [-g] [-x] [-max-procs N] [-csm-extend FILENAME] [-makefile FILENAME] [-compile-imports] [DIRECTORY] [OPTION ...]
    version ~a -- visit http://wiki.call-cc.org/eggref/5/csm to read the manual.\n"
    version)
  (exit code))

(set-sharp-read-syntax! #\>
  (lambda (port)
    (let ((text (scan-sharp-greater-string port)))
      `(foreign-declare ,text)) ))

(define (scan-sharp-greater-string port)
  (let ([out (open-output-string)])
    (let loop ()
      (let ((c (read-char port)))
	(cond ((eof-object? c)
	       (error "unexpected end of `#> ... <#' sequence"))
	      ((char=? c #\newline)
	       (newline out)
	       (loop) )
	      ((char=? c #\<)
	       (let ([c (read-char port)])
		 (if (eqv? #\# c)
		     (get-output-string out)
		     (begin
		       (write-char #\< out)
		       (write-char c out)
		       (loop) ) ) ) )
	      (else
	       (write-char c out)
	       (loop) ) ) ) ) ) )

(register-feature! #:compiling #:csm)

(parse-arguments (command-line-arguments))