Initial import of schemify tree.

tools/schemify-tree.scm

@@ -0,0 +1,83 @@
+(import (chicken process-context)
+	srfi-4
+	(chicken file)
+	(chicken pathname)
+	(chicken format))
+
+(define (get-argv)
+  (let* ((args (argv))
+	 (rargs (member "--" args)))
+    (if rargs
+	(cdr rargs)
+	(if (equal? (car args) "csi")
+	    '()
+	    (cdr args)))))
+
+(define args (get-argv))
+(when (not (eq? (length args) 1))
+  (display "usage: schemify-tree dir")
+  (newline)
+  (exit 1))
+
+(define dir (car args))
+(define modname
+  (if (null? (cdr args))
+      'frontend-data
+      (string->symbol (cadr args))))
+(define lookupname
+  (if (or (null? (cdr args))
+	  (null? (cddr args)))
+      'frontend-lookup
+      (string->symbol (caddr args))))
+
+(define (scan-dir-tree dir . cs)
+  (let ((col (if (null? cs)
+		 '()
+		 (car cs)))
+	(filenames (directory dir)))
+    (let loop ((filenames filenames)
+	       (col col))
+      (if (null? filenames)
+	  col
+	  (let* ((filename (car filenames))
+		 (fpath (make-pathname dir filename)))
+	    (if (directory-exists? fpath)
+		(loop (cdr filenames)
+		      (scan-dir-tree fpath col))
+		(loop (cdr filenames)
+		      (cons fpath col))))))))
+
+(define (load-dir-tree dir tree)
+  (let ((dir-len (string-length dir)))
+    (let loop ((tree tree)
+	       (alst '()))
+      (if (null? tree)
+	  alst
+	  (let* ((fpath (car tree))
+		 (key (substring fpath dir-len))
+		 (value (with-input-from-file fpath read-u8vector)))
+	    (loop (cdr tree)
+		  (cons (cons key value)
+			alst)))))))
+
+(define (make-tree-module dir name getter)
+  (let* ((tree (scan-dir-tree dir))
+	 (alst (load-dir-tree dir tree)))
+    `(module ,name (,getter)
+       (import scheme srfi-4 (chicken base))
+       (define alst ',alst)
+       (define (,getter key . vs)
+	 (let ((klst (assoc key alst)))
+	   (if klst
+	       (cdr klst)
+	       (if (null? vs)
+		   (error ,getter "key not found" key)
+		   (car vs))))))))
+
+(define (compile-tree-module dir name getter)
+  (with-output-to-file (format "~a.scm" name)
+    (lambda ()
+      (write (make-tree-module dir name getter))
+      (newline))))
+
+(compile-tree-module dir modname lookupname)