commit 3db2796c95f7569906b5ab064b429ab354485ef7
Author: Lassi Kortela <lassi@lassi.io>
Date:   Thu Sep 15 19:44:45 2022 +0300

    Initial commit

diff --git a/scheme-deps.sld b/scheme-deps.sld
new file mode 100644
index 0000000..657fb37
--- /dev/null
+++ b/scheme-deps.sld
@@ -0,0 +1,303 @@
+(define-library (scheme-deps)
+
+  (export main)
+
+  (import (except (scheme base) features)
+          (scheme file)
+          (scheme read)
+          (scheme write)
+          (only (srfi 1) append-map append-reverse fold any every remove)
+          (srfi 193))
+
+  (cond-expand
+   (chibi
+    (import (chibi show)
+            (chibi show pretty)))
+   (gauche
+    (import (only (gauche base) pprint)))
+   (else))
+
+  (cond-expand
+   (chibi
+    (begin
+      (define (pretty-print obj)
+        (show #t (pretty obj)))))
+   (gauche
+    (begin
+      (define (pretty-print obj)
+        (pprint obj))))
+   (else
+    (begin
+      (define (pretty-print obj)
+        (write obj)
+        (newline)))))
+
+  (begin
+
+    (define edisp
+      (lambda objs
+        (for-each (lambda (obj) (display obj (current-error-port)))
+                  objs)
+        (newline (current-error-port))))
+
+    (define (read-all)
+      (let loop ((xs '()))
+        (let ((x (read)))
+          (if (eof-object? x) (reverse xs) (loop (cons x xs))))))
+
+    ;;
+
+    (define (natural? obj)
+      (and (integer? obj) (exact? obj) (not (negative? obj))))
+
+    ;;
+
+    (define first car)
+    (define second cadr)
+
+    (define rest cdr)
+
+    (define (list<? < a b)
+      (cond ((null? a) (not (null? b)))
+            ((null? b) #f)
+            ((< (first a) (first b)) #t)
+            ((< (first b) (first a)) #f)
+            (else (list<? < (rest a) (rest b)))))
+
+    (define (sorted-insert-unique < elem list)
+      (let loop ((before '()) (tail list))
+        (cond ((or (not (pair? tail))
+                   (< elem (first tail)))
+               (append-reverse before (cons elem tail)))
+              ((< (first tail) elem)
+               (loop (cons (first tail) before)
+                     (rest tail)))
+              (else
+               list))))
+
+    (define (sort-unique < list)
+      (let loop ((sorted '()) (list list))
+        (if (null? list)
+            sorted
+            (loop (sorted-insert-unique < (first list) sorted)
+                  (rest list)))))
+
+    (define (nonnull-list? obj)
+      (and (list? obj)
+           (not (null? obj))))
+
+    (define (head? form head)
+      (and (nonnull-list? form)
+           (equal? head (first form))))
+
+    (define (dehead form head)
+      (if (head? form head)
+          (rest form)
+          (error "Mismatch" form head)))
+
+    (define (if-nonnull head tail)
+      (if (null? tail) '() `((,head ,@tail))))
+
+    ;;
+
+    (define (string-join parts delim)
+      (if (null? parts)
+          ""
+          (fold (lambda (parts whole) (string-append whole delim parts))
+                (first parts)
+                (rest parts))))
+
+    ;;
+
+    (define (valid-library-name-part? obj)
+      (or (symbol? obj) (natural? obj)))
+
+    (define (valid-library-name? obj)
+      (and (nonnull-list? obj)
+           (every valid-library-name-part? obj)))
+
+    (define (library-name-part->string part)
+      (cond ((symbol? part) (symbol->string part))
+            ((number? part) (number->string part))
+            (else (error "Bad library name part" part))))
+
+    (define (library-name-part<? a b)
+      (string<? (library-name-part->string a)
+                (library-name-part->string b)))
+
+    (define (library-name<? a b)
+      (list<? library-name-part<? a b))
+
+    (define (format-library-name library-name separator extension)
+      (string-append (string-join (map library-name-part->string library-name)
+                                  separator)
+                     extension))
+
+    (define (library-name->filename library-name)
+      (format-library-name library-name "/" ".sld"))
+
+    ;;
+
+    (define (no-consumer value) (error "No consumer"))
+    (define (producer consumer) (lambda (value) ((consumer) value)))
+
+    (define consume-name    (make-parameter no-consumer))
+    (define consume-import  (make-parameter no-consumer))
+    (define consume-include (make-parameter no-consumer))
+
+    (define produce-name    (producer consume-name))
+    (define produce-import  (producer consume-import))
+    (define produce-include (producer consume-include))
+
+    (define features (make-parameter '()))
+    (define libraries (make-parameter '()))
+
+    ;;
+
+    (define (requirement-satisfied? exp)
+      (cond ((symbol? exp)
+             (not (not (member exp (features)))))
+            ((head? exp 'library)
+             (if (= 2 (length exp))
+                 (not (not (member (second exp) (libraries))))
+                 (error "Bad (library ...) requirement")))
+            ((head? exp 'not)
+             (if (= 2 (length exp))
+                 (not (requirement-satisfied? (second exp)))
+                 (error "Bad (not ...) requirement" exp)))
+            ((head? exp 'and)
+             (every requirement-satisfied? exp))
+            ((head? exp 'or)
+             (any requirement-satisfied? exp))
+            (else
+             (error "Bad cond-expand requirement" exp))))
+
+    (define (walk-cond-expand form)
+      (let loop ((clauses (dehead form 'cond-expand)))
+        (if (null? clauses)
+            (error "No cond-expand clause matches these features" (features))
+            (let ((clause (first clauses)))
+              (cond ((not (nonnull-list? clause))
+                     (error "Bad cond-expand clause" clause))
+                    ((or (equal? 'else (first clause))
+                         (requirement-satisfied? (first clause)))
+                     (walk-library-declarations (rest clause)))
+                    (else
+                     (loop (rest clauses))))))))
+
+    (define (walk-include form)
+      (if (and (head? form 'include) (= 2 (length form)))
+          (produce-include (second form))
+          (error "Bad include" form)))
+
+    (define (walk-import-set import-set)
+      (cond ((or (head? import-set 'except)
+                 (head? import-set 'only)
+                 (head? import-set 'prefix)
+                 (head? import-set 'rename))
+             (walk-import-set (second import-set)))
+            ((list? import-set)
+             (produce-import import-set))
+            (else
+             (error "Bad import set" import-set))))
+
+    (define (walk-import form)
+      (for-each walk-import-set (dehead form 'import)))
+
+    (define ignored-declarations
+      '(begin export))
+
+    (define (walk-library-declaration decl)
+      (cond ((head? decl 'cond-expand)
+             (walk-cond-expand decl))
+            ((head? decl 'include)
+             (walk-include decl))
+            ((head? decl 'import)
+             (walk-import decl))
+            ((and (nonnull-list? decl)
+                  (member (first decl) ignored-declarations))
+             (values))
+            (else
+             (edisp "warning: ignoring unknown library declaration " decl)
+             (values))))
+
+    (define (walk-library-declarations decls)
+      (for-each walk-library-declaration decls))
+
+    (define (walk-define-library exp)
+      (unless (and (head? exp 'define-library) (>= (length exp) 3))
+        (error "Bad define-library" exp))
+      (let ((name (second exp))
+            (decls (rest (rest exp))))
+        (unless (valid-library-name? name)
+          (error "Bad library name" name))
+        (produce-name name)
+        (walk-library-declarations decls)))
+
+    (define (walk-sld-file sld-file)
+      (for-each walk-define-library
+                (with-input-from-file sld-file read-all)))
+
+    (define-record-type <library>
+      (make-library name source-file imports includes)
+      library?
+      (name library-name)
+      (source-file library-source-file)
+      (imports library-imports)
+      (includes library-includes))
+
+    (define (standard-or-implementation-library? library-name)
+      (member (first library-name)
+              '(chicken rnrs scheme srfi)))
+
+    (define (library->chicken-extension library)
+      (define (library-name->chicken library-name)
+        (string->symbol (format-library-name library-name "." "")))
+      `(extension
+        ,(library-name->chicken (library-name library))
+        (source ,(library-source-file library))
+        ,@(if-nonnull 'source-dependencies
+                      (library-includes library))
+        ,@(if-nonnull 'component-dependencies
+                      (map library-name->chicken
+                           (remove standard-or-implementation-library?
+                                   (library-imports library))))
+        (csc-options "-R" "r7rs"
+                     "-X" "r7rs")))
+
+    (define-syntax add-to
+      (syntax-rules ()
+        ((add-to lis <)
+         (lambda (elem)
+           (set! lis (sorted-insert-unique < elem lis))))))
+
+    (define (process-sld-file sld-file)
+      (let ((name '())
+            (imports '())
+            (includes '()))
+        (parameterize ((consume-name    (lambda (x) (set! name x)))
+                       (consume-import  (add-to imports library-name<?))
+                       (consume-include (add-to includes string<?)))
+          (walk-sld-file sld-file))
+        (make-library name sld-file imports includes)))
+
+    (define (print-chicken libs)
+      (for-each
+       pretty-print
+       `((distribution-files
+          ,@(sort-unique
+             string<?
+             (append-map (lambda (lib)
+                           (cons (library-source-file lib)
+                                 (library-includes lib)))
+                         libs)))
+         (components
+          ,@(map library->chicken-extension
+                 libs)))))
+
+    (define main
+      (lambda ignored
+        (parameterize ((features '(chicken))
+                       (libraries '((srfi 13))))
+          (let ((libs (map process-sld-file (command-args))))
+            (print-chicken libs)))))))