diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 03e54047c..c52984f4c 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -24,6 +24,7 @@ :use-module (system il ghil) :use-module (ice-9 match) :use-module (ice-9 receive) + :use-module ((system base compile) :select (syntax-error)) :export (translate)) (define (translate x e) @@ -41,10 +42,12 @@ (define (trans e l x) (cond ((pair? x) - (let ((y (macroexpand x))) - (if (eq? x y) - (trans-pair e (or (location x) l) (car x) (cdr x)) - (trans e l y)))) + (let ((y (false-if-exception (macroexpand x)))) + (if (not y) + (syntax-error l "failed to expand macro" x) + (if (eq? x y) + (trans-pair e (or (location x) l) (car x) (cdr x)) + (trans e l y))))) ((symbol? x) (let ((y (symbol-expand x))) (if (symbol? y) @@ -240,8 +243,15 @@ (else (if (memq head scheme-primitives) - ( e l head (map trans:x tail)) - ( e l (trans:x head) (map trans:x tail)))))) + ( e l head (map trans:x tail)) + (if (eq? head 'procedure->memoizing-macro) + ;;; XXX: `procedure->memoizing-macro' is evil because it crosses + ;;; the compilation boundary. One solution might be to evaluate + ;;; calls to `procedure->memoizing-macro' at compilation time, + ;;; but it may be more compicated than that. + (syntax-error l "`procedure->memoizing-macro' is forbidden" + (cons head tail)) + ( e l (trans:x head) (map trans:x tail))))))) (define (trans-quasiquote e l x) (cond ((not (pair? x)) x) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 6ce3e477f..efed2badf 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -25,7 +25,7 @@ :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)) :use-module (system vm assemble) :use-module (ice-9 regex)) @@ -41,11 +41,14 @@ (define-public (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)))) + (format #t "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp)))) + +(export-syntax call-with-compile-error-catch) + ;;; @@ -56,10 +59,10 @@ (define-public (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)) @@ -68,7 +71,7 @@ (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: ") @@ -120,6 +123,7 @@ ;; translate (set! x (lang.translator x e)) (if (memq :t opts) (throw 'result x)) + (format #t "transed~%") ;; compile (set! x (apply compile x e opts)) (if (memq :c opts) (throw 'result x))