Added support for defmacro' and define-macro' in the compiler.

* module/language/scheme/translate.scm: Use `(srfi srfi-39)'.
  (&current-macros): New top-level.
  (expand-macro): New.
  (scheme-primitives): Renamed `%scheme-primitives'.
  (%forbidden-primitives): New.
  (trans): Use `expand-macro' instead of `macroexpand'.
  (trans-pair): Handle `define-macro' and `defmacro'.

* module/system/base/compile.scm (call-with-compile-error-catch): Handle
  non-pair LOC.

* testsuite/t-macros2.scm: New test case.

* testsuite/Makefile.am (vm_test_files): Updated.

* testsuite/t-macros.scm: Test `read-options'.

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

module/language/scheme/translate.scm

@@ -24,25 +24,67 @@
   :use-module (system il ghil)
   :use-module (ice-9 match)
   :use-module (ice-9 receive)
+  :use-module (srfi srfi-39)
   :use-module ((system base compile) :select (syntax-error))
   :export (translate))
 
+
+;; Hash table containing the macros currently defined.
+(define &current-macros (make-parameter #f))
+
 (define (translate x e)
+  (parameterize ((&current-macros (make-hash-table)))
     (call-with-ghil-environment (make-ghil-mod e) '()
       (lambda (env vars)
-      (<ghil-lambda> env #f vars #f (trans env #f x)))))
+	(<ghil-lambda> env #f vars #f (trans env #f x))))))
+
+
+;;;
+;;; Macro tricks
+;;;
+
+(define (expand-macro e)
+  ;; Similar to `macroexpand' in `boot-9.scm' except that it does not expand
+  ;; `define-macro' and `defmacro'.
+  (cond
+   ((pair? e)
+    (let* ((head (car e))
+	   (val (and (symbol? head) (local-ref (list head)))))
+      (case head
+	((defmacro define-macro)
+	 ;; Normally, these are expanded as `defmacro:transformer' but we
+	 ;; don't want it to happen.
+	 e)
+	(else
+	 (if (defmacro? val) ;; built-in macro?
+	     (expand-macro (apply (defmacro-transformer val) (cdr e)))
+	     (let ((local-macro (hashq-ref (&current-macros) head)))
+	       (if (not local-macro)
+		   e
+		   (if (procedure? local-macro)
+		       (expand-macro (apply local-macro (cdr e)))
+		       (syntax-error #f (format #f "~a: invalid macro" head)
+				     local-macro)))))))))
+   (#t e)))
 
 
 ;;;
 ;;; Translator
 ;;;
 
-(define scheme-primitives
+(define %scheme-primitives
   '(not null? eq? eqv? equal? pair? list? cons car cdr set-car! set-cdr!))
 
+(define %forbidden-primitives
+  ;; Guile's `procedure->macro' family 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.
+  '(procedure->syntax procedure->macro procedure->memoizing-macro))
+
 (define (trans e l x)
   (cond ((pair? x)
-	 (let ((y (false-if-exception (macroexpand x))))
+	 (let ((y (false-if-exception (expand-macro x))))
 	   (if (not y)
 	       (syntax-error l "failed to expand macro" x)
 	       (if (eq? x y)
@@ -103,6 +145,22 @@
 
        (else (bad-syntax))))
 
+    ;; simple macros
+    ((defmacro define-macro)
+     (let* ((shortcut? (eq? head 'defmacro))
+	    (macro-name (if shortcut? (car tail) (caar tail)))
+	    (formal-args (if shortcut? (cadr tail) (cdar tail)))
+	    (body (if shortcut? (cddr tail) (cdr tail))))
+
+       (hashq-set! (&current-macros) macro-name
+		   ;; FIXME: The lambda is evaluated in the current module.
+		   (primitive-eval `(lambda ,formal-args ,@body)))
+
+;        (format (current-error-port) "macro `~a': ~a~%"
+; 	       macro-name (hashq-ref (&current-macros) macro-name))
+
+       (make:void)))
+
     ((set!)
      (match tail
        ;; (set! NAME VAL)
@@ -242,14 +300,10 @@
 	 (else (bad-syntax)))))
 
     (else
-     (if (memq head scheme-primitives)
+     (if (memq head %scheme-primitives)
 	 (<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"
+	 (if (member head %forbidden-primitives)
+	     (syntax-error l (format #f "`~a' is forbidden" head)
 			   (cons head tail))
 	     (<ghil-call> e l (trans:x head) (map trans:x tail)))))))
 

module/system/base/compile.scm

@@ -45,7 +45,9 @@
   `(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)
 
@@ -123,7 +125,6 @@
       ;; 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))

testsuite/Makefile.am

@@ -10,6 +10,7 @@ vm_test_files =					\
       t-closure3.scm				\
       t-do-loop.scm				\
       t-macros.scm				\
+      t-macros2.scm				\
       t-proc-with-setter.scm			\
       t-values.scm				\
       t-records.scm				\

testsuite/t-macros.scm

@@ -1,3 +1,4 @@
-;; Are macros well-expanded at compilation-time?
+;; Are built-in macros well-expanded at compilation-time?
 
 (false-if-exception (+ 2 2))
+(read-options)

testsuite/t-macros2.scm

@@ -0,0 +1,17 @@
+;; Are macros well-expanded at compilation-time?
+
+(defmacro minus-binary (a b)
+  `(- ,a ,b))
+
+(define-macro (plus . args)
+  `(let ((res (+ ,@args)))
+     ;;(format #t "plus -> ~a~%" res)
+     res))
+
+
+(plus (let* ((x (minus-binary 12 7)) ;; 5
+	     (y (minus-binary x 1))) ;; 4
+	(plus x y 5)) ;; 14
+      12              ;; 26
+      (expt 2 3))     ;; => 34
+