#!/usr/bin/env chibi-scheme

;; This is a build-only tool (not installed) used to generate the
;; clibs.c file used by Chibi for a SEXP_USE_STATIC_LIBS=1 build,
;; i.e. a build of Chibi with all libraries that would be loaded
;; dynamically included statically into libchibi-scheme (though not
;; necessarily statically linked).
;;
;; Usage:
;;   find <dir> -name \*.sld | chibi-genstatic [-x <mods> ...] > clibs.c
;;   chibi-genstatic -i <mods> > clibs.c
;;
;; In the first form, chibi-genstatic takes a list of module file
;; names on stdin to generate static bindings for, excluding any
;; modules specified with -x (or --exclude).
;;
;; In the second form, we take an explicit list of module names as
;; options with -i or --include (-x is still honored and takes
;; precedence).
;;
;; Both -i and -x may be specified multiple times, or multiple module
;; names can be separated with commas.
;;
;; Examples:
;;  find lib -name \*.sld | chibi-genstatic -x chibi.net -x srfi.18 > clibs.c
;;  chibi-genstatic -i chibi.ast,srfi.69 > clibs.c
;;
;; This is only intended for libraries in the core distribution, and
;; currently makes the assumption that the .sld files contain a
;; `define-library' form.  If you want to make a custom build with
;; your own libraries included statically, be sure to follow this
;; convention.
;;
;; Note: This relies on an external find, instead of one from (chibi
;; filesystem), because the latter is a dynamically loaded library
;; which presents a bootstrapping issue on platforms with no dynamic
;; loading.

(import (chibi))

;; inlined from (meta) and (chibi string)

(define (find-module name)
  #f)

(define (module-name->strings ls res)
  (if (null? ls)
      res
      (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls)))
                       ((number? (car ls)) (number->string (car ls)))
                       ((string? (car ls)) (car ls))
                       (else (error "invalid module name" (car ls))))))
        (module-name->strings (cdr ls) (cons "/" (cons str res))))))

(define (module-name->file name)
  (string-concatenate
   (reverse (cons ".sld" (cdr (module-name->strings name '()))))))

(define (make-char-predicate x)
  (cond ((procedure? x) x)
        ((char? x) (lambda (ch) (eq? ch x)))
        (else (error "invalid character predicate" x))))

(define (complement pred) (lambda (x) (not (pred x))))

(define (string-find str x . o)
  (let ((pred (make-char-predicate x))
        (end (if (and (pair? o) (pair? (cdr o)))
                 (cadr o)
                 (string-cursor-end str))))
    (let lp ((i (if (pair? o) (car o) (string-cursor-start str))))
      (cond ((string-cursor>=? i end) end)
            ((pred (string-cursor-ref str i)) i)
            (else (lp (string-cursor-next str i)))))))

(define (string-find-right str x . o)
  (let ((pred (make-char-predicate x))
        (start (if (pair? o) (car o) (string-cursor-start str))))
    (let lp ((i (if (and (pair? o) (pair? (cdr o)))
                    (cadr o)
                    (string-cursor-end str))))
      (let ((i2 (string-cursor-prev str i)))
        (cond ((string-cursor<? i2 start) start)
              ((pred (string-cursor-ref str i2)) i)
              (else (lp i2)))))))

(define (string-skip str x . o)
  (apply string-find str (complement (make-char-predicate x)) o))

(define (string-skip-right str x . o)
  (apply string-find-right str (complement (make-char-predicate x)) o))

(define (string-suffix? suffix str)
  (let ((suf-len (string-length suffix))
        (str-len (string-length str)))
    (and (>= str-len suf-len)
         (equal? suffix (substring str (- str-len suf-len))))))

(define (path-strip-directory path)
  (substring-cursor path (string-find-right path #\/)))

(define (path-directory path)
  (if (string=? path "")
      "."
      (let ((zero (string-cursor-start path))
            (end (string-skip-right path #\/)))
        (if (string-cursor<=? end zero)
            "/"
            (let ((start (string-find-right path #\/ zero end)))
              (if (string-cursor<=? start zero)
                  "."
                  (let ((start2 (string-skip-right path #\/ zero start)))
                    (if (string-cursor<=? start2 zero)
                        "/"
                        (substring-cursor path zero start2)))))))))

(define (path-extension-pos path)
  (let ((start (string-cursor-start path))
        (end (string-cursor-end path)))
    (let lp ((i end) (dot #f))
      (if (string-cursor<=? i start)
          #f
          (let* ((i2 (string-cursor-prev path i))
                 (ch (string-cursor-ref path i2)))
            (cond ((eqv? #\. ch)
                   (and (string-cursor<? i end) (lp i2 (or dot i))))
                  ((eqv? #\/ ch) #f)
                  (dot)
                  (else (lp i2 #f))))))))

(define (path-extension path)
  (let ((i (path-extension-pos path)))
    (and i
         (substring-cursor path i))))

(define (path-strip-extension path)
  (let ((i (path-extension-pos path)))
    (if i
        (substring-cursor path
                          (string-cursor-start path)
                          (string-cursor-prev path i))
        path)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (x->string x)
  (cond ((string? x) x)
        ((symbol? x) (symbol->string x))
        ((number? x) (number->string x))
        (else (error "non-stringable object" x))))

(define (string-split str c . o)
  (let ((start (if (pair? o) (car o) 0))
        (end (string-length str)))
    (let lp ((from start) (i start) (res '()))
      (define (collect) (if (= i from) res (cons (substring str from i) res)))
      (cond
       ((>= i end) (reverse (collect)))
       ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (collect)))
       (else (lp from (+ i 1) res))))))

(define (string-replace str c r)
  (let ((len (string-length str)))
    (let lp ((from 0) (i 0) (res '()))
      (define (collect) (if (= i from) res (cons (substring str from i) res)))
      (cond
       ((>= i len) (string-concatenate (reverse (collect))))
       ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect))))
       (else (lp from (+ i 1) res))))))

(define (c-char? c)
  (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?))))

(define (c-escape str)
  (define (hex ch) (number->string (char->integer ch) 16))
  (let ((len (string-length str)))
    (let lp ((from 0) (i 0) (res '()))
      (define (collect) (if (= i from) res (cons (substring str from i) res)))
      (cond
       ((>= i len)
        (string-concatenate (reverse (collect))))
       ((not (c-char? (string-ref str i)))
        (lp (+ i 1)
            (+ i 1)
            (cons "_" (cons (hex (string-ref str i)) (collect)))))
       (else
        (lp from (+ i 1) res))))))

(define (mangle x)
  (string-replace
   (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p")
   #\! "_x"))

(define (read-line . o)
  (let ((in (if (pair? o) (car o) (current-input-port))))
    (let lp ((res '()))
      (let ((c (read-char in)))
        (cond
         ((eof-object? c)
          (if (null? res) c (list->string (reverse res))))
         ((eqv? c #\newline)
          (list->string (reverse res)))
         (else
          (lp (cons c res))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (strip-dot-slash path)
  (if (and (>= (string-length path) 2)
           (eq? #\. (string-ref path 0))
           (eq? #\/ (string-ref path 1)))
      (substring path 2)
      path))

(define (shared-file-name mod-name name)
  (string-append
   (path-directory
    (strip-dot-slash (find-module-file (module-name->file mod-name))))
   "/" name))

(define (find-c-libs-from-module-names modules)
  (define (find-c-lib mod-name)
    (cond
     ((find-module mod-name)
      => (lambda (mod)
           (cond
            ((assq 'include-shared (vector-ref mod 2))
             => (lambda (x)
                  (cons (shared-file-name mod-name (cadr x)) mod-name)))
            (else #f))))
     (else #f)))
  (let lp ((ls modules)
           (c-libs '()))
    (cond
     ((null? ls)
      c-libs)
     ((find-c-lib (car ls))
      => (lambda (x) (lp (cdr ls) (cons x c-libs))))
     (else
      (lp (cdr ls) c-libs)))))

(define (find-c-libs-from-file-names excluded)
  (define (check-cond-expand x)
    (if (pair? x)
        (case (car x)
          ((and) (every check-cond-expand (cdr x)))
          ((or) (any check-cond-expand (cdr x)))
          ((not) (not (check-cond-expand (cadr x))))
          ((library) (eval `(find-module ',(cadr x)) (%meta-env)))
          (else (error "cond-expand: bad feature" x)))
        (memq (identifier->symbol x) *features*)))
  (define (extract-module-name file)
    (call-with-input-file file
      (lambda (in)
        (protect
         (exn (else #f))
         (let lp ()
           (let ((expr (read in)))
             (cond
              ((eof-object? expr) #f)
              ((and (pair? expr)
                    (pair? (cdr expr))
                    (memq (car expr)
                          '(define-library define-module library module)))
               (cadr expr))
              (else (lp)))))))))
  (define (extract-module-shares mod-name file)
    (call-with-input-file file
      (lambda (in)
        (let lp ()
          (let ((expr (read in)))
            (cond
             ((eof-object? expr) '())
             ((and (pair? expr)
                   (pair? (cdr expr))
                   (memq (car expr)
                         '(define-library define-module library module)))
              (let lp ((ls (cdr expr)) (c-libs '()))
                (cond
                 ((null? ls) c-libs)
                 ((not (pair? (car ls))) (lp (cdr ls) c-libs))
                 ((eq? 'include-shared (caar ls))
                  (lp (cdr ls)
                      (cons (cons (shared-file-name mod-name (cadr (car ls)))
                                  mod-name)
                            c-libs)))
                 ((eq? 'cond-expand (caar ls))
                  (let expand ((ls2 (cdar ls)) (res (cdr ls)))
                    (cond
                     ((null? ls2) (lp res c-libs))
                     ((check-cond-expand (caar ls2))
                      (expand (cdr ls2) (append (cdar ls2) res)))
                     (else (expand (cdr ls2) res)))))
                 (else (lp (cdr ls) c-libs)))))
             (else (lp))))))))
  (let lp ((modules '()))
    (let ((file (read-line)))
      (cond
       ((or (eof-object? file) (equal? "" file))
        modules)
       ((extract-module-name file)
        => (lambda (name)
             (lp (if (member name excluded)
                     modules
                     (append (extract-module-shares name file) modules)))))
       (else
        (lp modules))))))

(define (find-c-libs includes excludes cfiles)
  (cons (if includes
            (find-c-libs-from-module-names includes)
            (find-c-libs-from-file-names excludes))
        cfiles))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define wdir "")

(define (init-name mod)
  (string-append "sexp_init_lib_"
                 (string-concatenate (map mangle mod) "_")))

(define (include-c-lib lib c-files . o)
  (display "#define sexp_init_library ")
  (display (init-name (cdr lib)))
  (newline)
  (cond
   ((and (pair? o) (car o))  ; inline
    (let* ((mod-strings (cdr (module-name->strings (cdr lib) '())))
           (share-file (path-strip-directory (car lib)))
           ;; ugly hack allowing include-shared of files only up to
           ;; one subdirectory beneath
           (base0 (string-concatenate
                   (reverse (cons share-file (cons "/" mod-strings)))))
           (base1 (string-concatenate
                   (reverse (cons share-file (cdr mod-strings)))))
           (in (protect
                (exn
                 (else
                  (let lp ((ls c-files))
                    (cond
                     ((null? ls)
                      (error "couldn't find c file" base0 base1 c-files))
                     ((and (member (path-extension (car ls)) '("c" "cc"))
                           (let ((f (path-strip-extension (car ls))))
                             (or (string-suffix? base0 f)
                                 (string-suffix? base1 f))))
                      (open-input-file (car ls)))
                     (else (lp (cdr ls)))))))
                (protect
                 (exn
                  (else
                   (protect
                    (exn (else (open-input-file (string-append base1 ".c"))))
                    (open-input-file (string-append base0 ".c")))))
                 (open-input-file (string-append (car lib) ".c"))))))
      (let lp ()
        (let ((line (read-line in)))
          (cond
           ((eof-object? line)
            (close-input-port in))
           (else
            (display line)
            (newline)
            (lp)))))))
   (else
    (display "#include \"")
    (display (string-append (car lib) ".c"))
    (display "\"")
    (newline)))
  (display "#undef sexp_init_library")
  (newline)
  (newline))

(define (init-c-lib lib)
  (display "  { \"")
  (display (car lib))
  (display "\", ")
  (display (init-name (cdr lib)))
  (display " },\n"))

(define (split-mod-names str)
  (map (lambda (m)
         (map (lambda (x) (or (string->number x) (string->symbol x)))
              (string-split m #\.)))
       (string-split str #\,)))

(let ((args (command-line)))
  (if (pair? args)
      (set! wdir (path-directory (path-directory (car args)))))
  (let lp ((args (if (pair? args) (cdr args) args))
           (features '())
           (includes #f)
           (excludes '())
           (cfiles '())
           (inline? #t))
    (cond
     ((and (pair? args) (not (equal? "" (car args)))
           (eqv? #\- (string-ref (car args) 0)))
      (case (string->symbol (car args))
        ((--inline)
         (lp (cdr args) features includes excludes cfiles #t))
        ((--no-inline)
         (lp (cdr args) features includes excludes cfiles #f))
        ((--features)
         (if (null? (cdr args))
             (error "--features requires an argument"))
         (lp (cddr args) (append features (string-split (cadr args) #\,))
             includes excludes cfiles inline?))
        ((-i --include)
         (lp (cddr args) features
             (append (or includes '()) (split-mod-names (cadr args)))
             excludes cfiles inline?))
        ((-x --exclude)
         (lp (cddr args) features includes
             (append excludes (split-mod-names (cadr args)))
             cfiles inline?))
        ((-c --cfiles)
         (lp (cddr args) features includes excludes
             (append cfiles (string-split (cadr args) #\,)) inline?))
        ((-C --all-cfiles)
         (lp '() features includes excludes (append cfiles (cdr args)) inline?))
        (else
         (error "unknown option" (car args)))))
     (else
      (if (pair? features)
          (set! *features* features))
      (let* ((c-libs+c-files (find-c-libs includes excludes cfiles))
             (c-libs (car c-libs+c-files))
             (c-files (cdr c-libs+c-files)))
        (display "#include \"chibi/eval.h\"\n")
        (newline)
        (for-each (lambda (x) (include-c-lib x c-files inline?)) c-libs)
        (newline)
        (display "struct sexp_library_entry_t sexp_static_libraries_array[] = {\n")
        (for-each init-c-lib c-libs)
        (display "  { NULL, NULL }\n")
        (display "};\n\n")
        (display "struct sexp_library_entry_t* sexp_static_libraries = sexp_static_libraries_array;\n"))))))