Fixed error handling; detect and report macro expansion errors.

* module/language/scheme/translate.scm (trans): Catch exceptions thrown
  by `macroexpand' and throw a syntax error.
  (trans-pair): Catch calls to `procedure->memoizing-macro' and raise a
  syntax error.

* module/system/base/compile.scm (call-with-compile-error-catch): Made a
  macro (a procedure doesn't do the job).
  (compile-file): Uncommented call to `call-with-compile-error-catch'.

git-archimport-id: lcourtes@laas.fr--2005-mobile/guile-vm--mobile--0.6--patch-7

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)
-       (<ghil-inline> e l head (map trans:x tail))
-       (<ghil-call> e l (trans:x head) (map trans:x tail))))))
+	 (<ghil-inline> 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))
+	     (<ghil-call> e l (trans:x head) (map trans:x tail)))))))
 
 (define (trans-quasiquote e l x)
   (cond ((not (pair? x)) x)

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))