syncase macros compiling!

[bpt/guile.git] / module / system / base / compile.scm

diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index bd7f696..537d81e 100644 (file)
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -25,50 +25,53 @@
   :use-module (system il compile)
   :use-module (system il glil)
   :use-module ((system vm core)
-              #:select (the-vm vm-load objcode->u8vector))
+              :select (the-vm vm-load objcode->u8vector load-objcode))
   :use-module (system vm assemble)
-  :use-module (ice-9 regex))
+  :use-module (ice-9 regex)
+  :export (syntax-error compile-file load-source-file load-file
+           compiled-file-name
+           scheme-eval read-file-in compile-in))
 
 ;;;
 ;;; Compiler environment
 ;;;
 
-(define-record (<cenv> vm language module))
-
-(define-public (make-cenv . rest)
-  (apply <cenv> rest))
-
-(define-public (syntax-error loc msg exp)
+(define (syntax-error loc msg exp)
   (throw 'syntax-error loc msg exp))
 
-(define-public (call-with-compile-error-catch thunk)
-  (catch 'syntax-error
-        (thunk)
+(define-macro (call-with-compile-error-catch thunk)
+  `(catch 'syntax-error
+        ,thunk
         (lambda (key loc msg exp)
-          (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
+          (if (pair? loc)
+              (format #t "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp)
+              (format #t "unknown location: ~A: ~A~%" msg exp)))))
+
+(export-syntax  call-with-compile-error-catch)
+
 
 \f
 ;;;
 ;;; Compiler
 ;;;
 
-(define scheme (lookup-language 'scheme))
+(define (scheme) (lookup-language 'scheme))
 
-(define-public (compile-file file . opts)
+(define (compile-file file . opts)
   (let ((comp (compiled-file-name file)))
-    (catch #t
+    (catch 'nothing-at-all
       (lambda ()
-;      (call-with-compile-error-catch
-;       (lambda ()
+       (call-with-compile-error-catch
+        (lambda ()
           (call-with-output-file comp
             (lambda (port)
-              (let* ((source (read-file-in file scheme))
+              (let* ((source (read-file-in file (scheme)))
                      (objcode (apply compile-in source (current-module)
-                                     scheme opts)))
+                                     (scheme) opts)))
                 (if (memq :c opts)
                   (pprint-glil objcode port)
                   (uniform-vector-write (objcode->u8vector objcode) port)))))
-          (format #t "wrote ~A\n" comp))
+          (format #t "wrote `~A'\n" comp))))
       (lambda (key . args)
        (format #t "ERROR: during compilation of ~A:\n" file)
        (display "ERROR: ")
@@ -86,39 +89,39 @@
 ;          (format #t "compile-file: returned ~a~%" result)
 ;          result))))
 
-(define-public (load-source-file file . opts)
-  (let ((source (read-file-in file scheme)))
-    (apply compile-in source (current-module) scheme opts)))
+(define (load-source-file file . opts)
+  (let ((source (read-file-in file (scheme))))
+    (apply compile-in source (current-module) (scheme) opts)))
 
-(define-public (load-file file . opts)
+(define (load-file file . opts)
   (let ((comp (compiled-file-name file)))
     (if (file-exists? comp)
        (load-objcode comp)
        (apply load-source-file file opts))))
 
-(define-public (compiled-file-name file)
+(define (compiled-file-name file)
   (let ((m (string-match "\\.[^.]*$" file)))
     (string-append (if m (match:prefix m) file) ".go")))
 
-(define-public (scheme-eval x e)
-  (vm-load (the-vm) (compile-in x e scheme)))
+(define (scheme-eval x e)
+  (vm-load (the-vm) (compile-in x e (scheme))))
 
 \f
 ;;;
 ;;; Scheme compiler interface
 ;;;
 
-(define-public (read-file-in file lang)
-  (call-with-input-file file lang.read-file))
+(define (read-file-in file lang)
+  (call-with-input-file file (language-read-file lang)))
 
-(define-public (compile-in x e lang . opts)
+(define (compile-in x e lang . opts)
   (catch 'result
     (lambda ()
       ;; expand
-      (set! x (lang.expander x e))
+      (set! x ((language-expander lang) x e))
       (if (memq :e opts) (throw 'result x))
       ;; translate
-      (set! x (lang.translator x e))
+      (set! x ((language-translator lang) x e))
       (if (memq :t opts) (throw 'result x))
       ;; compile
       (set! x (apply compile x e opts))