mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

fix nested quasiquotes (yeepers)

Browse source 
* module/language/scheme/translate.scm (primitive-syntax-table)
  (trans-quasiquote): Fix handling of nested quasiquotes.

* testsuite/Makefile.am (vm_test_files):
* testsuite/t-quasiquote.scm: Add a quasiquote test case.
This commit is contained in:
Andy Wingo 2008-09-02 00:23:10 -07:00
parent e0b20b68b0
commit 124c52d8bb
3 changed files with 26 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

23
module/language/scheme/translate.scm
View file

@ -137,7 +137,7 @@
(quasiquote (quasiquote
;; (quasiquote OBJ) ;; (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
;; (define NAME VAL) ;; (define NAME VAL)
@ -293,18 +293,27 @@
runtime))) runtime)))
(else (syntax-error l "bad eval-case clause" (car in)))))))))))))) (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) (cond ((not (pair? x)) x)
((memq (car x) '(unquote unquote-splicing)) ((memq (car x) '(unquote unquote-splicing))
(let ((l (location x))) (let ((l (location x)))
(pmatch (cdr x) (pmatch (cdr x)
((,obj) ((,obj)
(if (eq? (car x) 'unquote) (cond
(make-ghil-unquote e l (trans e l obj)) ((zero? level)
(make-ghil-unquote-splicing e l (trans e l 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))))
(else
(list (car x) (trans-quasiquote e l obj (1- level))))))
(else (syntax-error l (format #f "bad ~A" (car x)) x))))) (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
(else (cons (trans-quasiquote e l (car x)) ((eq? (car x) 'quasiquote)
(trans-quasiquote e l (cdr x)))))) (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 (trans-body e l body)
(define (define->binding df) (define (define->binding df)

1
testsuite/Makefile.am
View file

@ -16,6 +16,7 @@ vm_test_files = \
t-map.scm \ t-map.scm \
t-or.scm \ t-or.scm \
t-proc-with-setter.scm \ t-proc-with-setter.scm \
t-quasiquote.scm \
t-values.scm \ t-values.scm \
t-records.scm \ t-records.scm \
t-match.scm \ t-match.scm \

9
testsuite/t-quasiquote.scm Normal file
View file

@ -0,0 +1,9 @@
(list
`()
`foo
`(foo)
`(foo bar)
`(1 2)
(let ((x 1)) `,x)
(let ((x 1)) `(,x))
(let ((x 1)) ``(,x)))