mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
Added support for defmacro' and
define-macro' in the compiler.
* module/language/scheme/translate.scm: Use `(srfi srfi-39)'. (¤t-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
This commit is contained in:
parent
d0100f476d
commit
2335fb97dc
5 changed files with 91 additions and 17 deletions
|
@ -6,12 +6,12 @@
|
|||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;; any later version.
|
||||
;;
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
|
@ -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 ¤t-macros (make-parameter #f))
|
||||
|
||||
(define (translate x e)
|
||||
(call-with-ghil-environment (make-ghil-mod e) '()
|
||||
(lambda (env vars)
|
||||
(<ghil-lambda> env #f vars #f (trans env #f x)))))
|
||||
(parameterize ((¤t-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))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; 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 (¤t-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! (¤t-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 (¤t-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)))))))
|
||||
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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 \
|
||||
|
|
|
@ -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)
|
||||
|
|
17
testsuite/t-macros2.scm
Normal file
17
testsuite/t-macros2.scm
Normal file
|
@ -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
|
||||
|
Loading…
Add table
Add a link
Reference in a new issue