1 files changed, 63 insertions, 13 deletions

@@ -7,7 +7,16 @@ Make r7rs library files out of source scheme files
 
 #+chicken (import (r7rs))
 (import (scheme base)
-        (scheme file))
+        (scheme file)
+        (scheme write)
+        (chicken pathname)
+        (chicken pretty-print)
+        (chicken string)
+        (utf8))
+
+(define (displayln str)
+  (display str)
+  (newline))
 
 (define (filter pred xs)
   (let loop ((pred pred)
@@ -22,22 +31,23 @@ Make r7rs library files out of source scheme files
       (loop pred (cdr xs) acc)))))
 
 (define (top-level-defines tree)
-  (filter (lambda (x)
-            (memq (car x)
-                  '( define
-                     define-syntax
-                     define-record-type
-                     define-values
-                     ;; others ?
-                     )))
-          tree))
-
-(define (top-level-names tree)
   (map (lambda (d)
          (if (pair? (cadr d))
              (caadr d)
              (cadr d)))
-       (top-level-defines tree)))
+       (filter (lambda (x)
+                 (memq (car x)
+                       '( define
+                          define-syntax
+                          define-record-type
+                          define-values
+                          ;; others ?
+                          )))
+               tree)))
+
+(define (top-level-imports tree)
+  (filter (lambda (x) (memq (car x) '(import)))
+          tree))
 
 (define (slurp-file file)
   (with-input-from-file file
@@ -48,3 +58,43 @@ Make r7rs library files out of source scheme files
             (reverse it)
             (loop (read) (cons next it)))))))
 
+(define (assq-ref x alist)
+  (and (assq x alist)
+       (cdr (assq x alist))
+       #f))
+
+(define (file->library-definition file . args)
+  (let* ((tree (slurp-file file))
+         (name (file->library-name file))
+         (exports (top-level-defines tree))
+         (imports (top-level-imports tree))
+         ;; Possibly: `include-library-interface' ?
+         (includer (or (assq-ref 'includer args) 'include))
+         (includes (list file)))
+    `(define-library ,name
+       (export ,@exports)
+       ,@imports
+       (,includer ,@includes))))
+
+(define (file->library-name file)
+  (map string->symbol
+       (string-split (pathname-file file) ".")))
+
+(define cond-expand-form
+  '(cond-expand
+     (chicken (import (r7rs)))
+     (else)))
+
+(define (write-library-definition library-definition . port)
+  (parameterize ((current-output-port (if (null? port)
+                                          (current-output-port)
+                                          port))
+                 (pretty-print-width 80))
+    (displayln (string-append ";;; " (->string
+                                      (cadr library-definition))
+                              " --- library definition"))
+    (displayln ";; This file was automatically generated by ruse.\n")
+    (pretty-print cond-expand-form)
+    (newline)
+    (pretty-print library-definition)
+    (newline)))