Implement compilation

TODO: Fix touch-p function.

diff --git a/src/thales/compile.scm b/src/thales/compile.scm
new file mode 100644 (file)
index 0000000..4a6d978
--- /dev/null
+++ b/src/thales/compile.scm
@@ -0,0 +1,66 @@
+(define-module (thales compile)
+    #:use-module (thales seal)
+    #:use-module (thales syntax)
+    #:use-module (system base compile)
+    #:use-module (thales prepare)
+    #:export (perform-compile mkdir-p with-current-working-directory
+                             touch-p))
+(define  (path-absolute? path)
+    (string-starts-with path "/"))
+
+(define-syntax with-current-working-directory
+    (syntax-rules ()
+       ((_ expr ...)
+        (let ((saved-cwd (getcwd)))
+            (catch #t
+                   (lambda () expr ... (chdir saved-cwd))
+                   (lambda args (chdir saved-cwd) (apply throw args)))))))
+
+(define-syntax with-ignored-exceptions
+    (syntax-rules ()
+       ((_ expr ...)
+        (catch #t (lambda () expr ...)
+                  (const #f)))))
+
+(define (mkdir-p path)
+    (define (make-and-step dir)
+       (unless (file-exists? dir)
+               (mkdir dir))
+       (chdir dir))
+    (with-current-working-directory
+        (when (path-absolute? path)
+             (chdir "/"))
+       (for-each make-and-step
+                 (string-split path #\/))))
+
+(define (touch-p path)
+    (with-ignored-exceptions
+        (mkdir-p path)
+       (rmdir path))
+    path)
+
+(sealed modname->relative-filename
+       (& '(foo bar) => "foo/bar.scm")
+       (& '(baz baf) #:extension ".go" => "baz/baf.go"))
+
+(define* (modname->relative-filename module #:key (extension ".scm"))
+    (string-append (string-join (map symbol->string module) "/")
+                  extension))
+
+(define (relative-to basename fname)
+    (format #f "~a/~a" basename fname))
+
+(define* (perform-compile modules #:key (srcdir ".") (outdir "."))
+    (define (source-filename modname)
+       (relative-to srcdir (modname->relative-filename modname)))
+    (define (output-filename modname)
+       (relative-to outdir (modname->relative-filename modname
+                                                       #:extension ".go")))
+    (define (toplevel-eval form) (eval form (resolve-module '(guile))))
+    (for (modname in modules)
+        (define source-fname (source-filename modname))
+        (define output-fname (output-filename modname))
+        (toplevel-eval `(define *thales-current-filename* ,source-fname))
+        (compile-file source-fname
+                      #:output-file (touch-p output-fname)
+                      #:env (current-module))))

diff --git a/src/thales/seal.scm b/src/thales/seal.scm
index 49462a6d1b4cc010ca0283c01334c46547fd30ee..cf980f76d33067c7f60e1061d14dde52a383ab41 100644 (file)
--- a/src/thales/seal.scm
+++ b/src/thales/seal.scm
@@ -90,7 +90,7 @@ In particular, (seal-clause expr -->) asserts, that EXPR throws something."))))
            ((_ f (obj ...) ...)
             (with-syntax ((& (datum->syntax env '&)))
                 #'(eval-when (compile)
-                             (load-once (current-filename))
+                             (load-once *thales-current-filename*)
                              (let ((& f))
                                  (format #t "Checking seals with & = ~a... " 'f)
                                  (seal-clause obj ...) ...