Inlining utils to make chibi-genstatic work without modules.

tools/chibi-genstatic

@@ -36,9 +36,76 @@
 ;; which presents a bootstrapping issue on platforms with no dynamic
 ;; loading.
 
-(import (chibi)
+(import (chibi))
-        (only (chibi pathname) path-directory)
+
-        (only (meta) find-module module-name->file))
+;; 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 (path-strip-directory path)
+  (substring-cursor path (string-find-right path #\/)))
+
+(define (path-directory path)
+  (if (string=? path "")
+      "."
+      (let ((end (string-skip-right path #\/)))
+        (if (zero? end)
+            "/"
+            (let ((start (string-find-right path #\/ 0 end)))
+              (if (zero? start)
+                  "."
+                  (let ((start2 (string-skip-right path #\/ 0 start)))
+                    (if (zero? start2)
+                        "/"
+                        (substring-cursor path 0 start2)))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -94,24 +161,30 @@
   (let ((in (if (pair? o) (car o) (current-input-port))))
     (let lp ((res '()))
       (let ((c (read-char in)))
-        (if (or (eof-object? c) (eqv? c #\newline))
+        (cond
-            (list->string (reverse res))
+         ((eof-object? c)
-            (lp (cons c res)))))))
+          (if (null? res) c (list->string (reverse res))))
+         ((eqv? c #\newline)
+          (list->string (reverse res)))
+         (else
+          (lp (cons c res))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (find-c-libs-from-module-names modules)
 (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)
@@ -133,6 +206,14 @@
       (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))))
+          (else (error "cond-expand: bad feature" x)))
+        (memq (identifier->symbol x) *features*)))
   (define (extract-module-name file)
     (call-with-input-file file
       (lambda (in)
@@ -146,14 +227,46 @@
                          '(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))
+                  ;;(lp (append (cdar ls) (cdr ls)) c-libs)
+                  (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))
-        (find-c-libs-from-module-names modules))
+        modules)
        ((extract-module-name file)
         => (lambda (name)
-             (lp (if (member name excluded) modules (cons name modules)))))
+             (lp (if (member name excluded)
+                     modules
+                     (append (extract-module-shares name file) modules)))))
        (else
         (lp modules))))))
 
@@ -165,39 +278,75 @@
          (string-split str #\,)))
   (let lp ((ls args)
            (includes #f)
-           (excludes '()))
+           (excludes '())
+           (cfiles '()))
     (cond
      ((null? ls)
+      (cons
        (if includes
            (find-c-libs-from-module-names includes)
-          (find-c-libs-from-file-names excludes)))
+           (find-c-libs-from-file-names excludes))
+       cfiles))
      (else
       (cond
        ((member (car ls) '("-i" "--include"))
         (lp (cddr ls)
             (append (or includes '()) (split-mod-names (cadr ls)))
-            excludes))
+            excludes
+            cfiles))
        ((member (car ls) '("-x" "--exclude"))
         (lp (cddr ls)
             includes
-            (append excludes (split-mod-names (cadr ls)))))
+            (append excludes (split-mod-names (cadr ls)))
+            cfiles))
+       ((member (car ls) '("-c" "--cfiles"))
+        (lp (cddr ls)
+            includes
+            excludes
+            (append cfiles (string-split (cadr ls) #\,))))
        (else
         (error "unknown arg" (car ls))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define wdir "")
+
 (define (init-name mod)
   (string-append "sexp_init_lib_"
                  (string-concatenate (map mangle mod) "_")))
 
-(define (include-c-lib lib)
+(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* ((base (string-append (car lib) ".c"))
+           (in (protect
+                (exn
+                 (else
+                  (let lp ((ls c-files))
+                    (cond
+                     ((null? ls) (error "couldn't find c file" base c-files))
+                     ((equal? (path-strip-directory (car ls))
+                              (path-strip-directory base))
+                      (open-input-file (car ls)))
+                     (else (lp (cdr ls)))))))
+                (open-input-file base))))
+      (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)
+    (newline)))
   (display "#undef sexp_init_library")
   (newline)
   (newline))
@@ -210,9 +359,14 @@
   (display " },\n"))
 
 (let* ((args (command-line))
-       (c-libs (find-c-libs (if (pair? args) (cdr args) args))))
+       (_ (if (pair? args)
+              (set! wdir (path-directory (path-directory (car args))))))
+       (c-libs+c-files (find-c-libs (if (pair? args) (cdr args) args)))
+       (c-libs (car c-libs+c-files))
+       (c-files (cdr c-libs+c-files))
+       (inline? #t))
   (newline)
-  (for-each include-c-lib c-libs)
+  (for-each (lambda (x) (include-c-lib x c-files inline?)) c-libs)
   (newline)
   ;; (display "typedef struct {\n")
   ;; (display "  const char *name;\n")