diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 24d3eadc5..31df82580 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -137,7 +137,7 @@ (quasiquote ;; (quasiquote OBJ) - ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj)))) + ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0)))) (define ;; (define NAME VAL) @@ -293,18 +293,27 @@ runtime))) (else (syntax-error l "bad eval-case clause" (car in)))))))))))))) -(define (trans-quasiquote e l x) +(define (trans-quasiquote e l x level) (cond ((not (pair? x)) x) ((memq (car x) '(unquote unquote-splicing)) (let ((l (location x))) (pmatch (cdr x) ((,obj) - (if (eq? (car x) 'unquote) - (make-ghil-unquote e l (trans e l obj)) - (make-ghil-unquote-splicing e l (trans e l obj)))) + (cond + ((zero? level) + (if (eq? (car x) 'unquote) + (make-ghil-unquote e l (trans e l obj)) + (make-ghil-unquote-splicing e l (trans e l obj)))) + (else + (list (car x) (trans-quasiquote e l obj (1- level)))))) (else (syntax-error l (format #f "bad ~A" (car x)) x))))) - (else (cons (trans-quasiquote e l (car x)) - (trans-quasiquote e l (cdr x)))))) + ((eq? (car x) 'quasiquote) + (let ((l (location x))) + (pmatch (cdr x) + ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level)))) + (else (syntax-error l (format #f "bad ~A" (car x)) x))))) + (else (cons (trans-quasiquote e l (car x) level) + (trans-quasiquote e l (cdr x) level))))) (define (trans-body e l body) (define (define->binding df) diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am index 04a3e97e7..59ef56587 100644 --- a/testsuite/Makefile.am +++ b/testsuite/Makefile.am @@ -16,6 +16,7 @@ vm_test_files = \ t-map.scm \ t-or.scm \ t-proc-with-setter.scm \ + t-quasiquote.scm \ t-values.scm \ t-records.scm \ t-match.scm \ diff --git a/testsuite/t-quasiquote.scm b/testsuite/t-quasiquote.scm new file mode 100644 index 000000000..6c482b8d8 --- /dev/null +++ b/testsuite/t-quasiquote.scm @@ -0,0 +1,9 @@ +(list + `() + `foo + `(foo) + `(foo bar) + `(1 2) + (let ((x 1)) `,x) + (let ((x 1)) `(,x)) + (let ((x 1)) ``(,x)))