Ticket #439: quasiquote-fix.patch

File quasiquote-fix.patch, 6.5 KB (added by sjamaan, 12 years ago)
  • expand.scm

    diff --git a/expand.scm b/expand.scm
    index 22b6a61..22d4b94 100644
    a b  
    13571357               (let ((head (car x))
    13581358                     (tail (cdr x)))
    13591359                 (cond ((c %unquote head)
    1360                         (if (pair? tail)
    1361                             (let ((hx (car tail)))
    1362                               (if (eq? n 0)
    1363                                   hx
    1364                                   (list '##sys#list `(##core#quote ,%unquote)
    1365                                         (walk hx (fx- n 1)) ) ) )
    1366                             `(##core#quote ,%unquote) ) )
     1360                        (cond ((eq? n 0)
     1361                               (##sys#check-syntax 'unquote x '(_ _))
     1362                               (car tail))
     1363                              (else (list '##sys#cons `(##core#quote ,%unquote)
     1364                                          (walk tail (fx- n 1)) ) )))
    13671365                       ((c %quasiquote head)
    1368                         (if (pair? tail)
    1369                             `(##sys#list (##core#quote ,%quasiquote)
    1370                                          ,(walk (car tail) (fx+ n 1)) )
    1371                             (list '##sys#cons (list '##core#quote %quasiquote)
    1372                                   (walk tail n)) ) )
    1373                        ((pair? head)
    1374                         (let ((hx (car head))
    1375                               (tx (cdr head)))
    1376                           (if (and (c hx %unquote-splicing) (pair? tx))
    1377                               (let ((htx (car tx)))
    1378                                 (if (eq? n 0)
    1379                                     `(##sys#append ,htx
    1380                                                    ,(walk tail n) )
    1381                                     `(##sys#cons (##sys#list (##core#quote ,%unquote-splicing)
    1382                                                              ,(walk htx (fx- n 1)) )
    1383                                                  ,(walk tail n) ) ) )
    1384                               `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) )
     1366                        (list '##sys#cons `(##core#quote ,%quasiquote)
     1367                              (walk tail (fx+ n 1)) ) )
     1368                       ((and (pair? head) (c %unquote-splicing (car head)))
     1369                        (cond ((eq? n 0)
     1370                               (##sys#check-syntax 'unquote-splicing head '(_ _))
     1371                               `(##sys#append ,(cadr head) ,(walk tail n)))
     1372                              (else
     1373                               `(##sys#cons
     1374                                 (##sys#cons (##core#quote ,%unquote-splicing)
     1375                                             ,(walk (cdr head) (fx- n 1)) )
     1376                                 ,(walk tail n)))))
    13851377                       (else
    13861378                        `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
    13871379      (define (simplify x)
  • tests/syntax-tests.scm

    diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
    index a66ef76..79a03dc 100644
    a b  
    1515(define-syntax f
    1616  (syntax-rules ()
    1717    ((_ x)
    18      (handle-exceptions ex (void)
    19        x
    20        (error "test returned, but should have failed" 'x) ))))
     18     (let ((got-error #f))
     19      (handle-exceptions ex (set! got-error #t) x)
     20      (unless got-error
     21        (error "test returned, but should have failed" 'x) )))))
    2122
    2223(t 3 3)
    2324
     
    702703       (map (cute + (begin (set! a (+ a 1)) a) <>)
    703704            '(1 2))
    704705       a))
    705 (f (eval '((cute + <...> 1) 1)))
    706  No newline at end of file
     706(f (eval '((cute + <...> 1) 1)))
     707
     708;;; (quasi-)quotation
     709
     710(f (eval '(let ((a 1)) (unquote a))))
     711(t 'unquote (quasiquote unquote))
     712(f (eval '(quasiquote (a unquote . 1)))) ; "Bad syntax". Also ok: '(a unquote . 1)
     713(t 'a (quasiquote a))
     714(f (eval '(quasiquote a b)))
     715(f (eval '(quote a b)))
     716(f (eval '(quasiquote)))
     717(f (eval '(quote)))
     718(f (eval '(quasiquote . a)))
     719(f (eval '(quote . a)))
     720(t '(foo . 1) (let ((bar 1))
     721                (quasiquote (foo . (unquote bar)))))
     722(f (eval '(let ((a 1)
     723                (b 2))
     724            (quasiquote (unquote a b))))) ; > 1 arg
     725
     726(t '(quasiquote (unquote a)) (quasiquote (quasiquote (unquote a))))
     727(t '(quasiquote x y) (quasiquote (quasiquote x y)))
     728
     729(t '(unquote-splicing a) (quasiquote (unquote-splicing a)))
     730(t '(1 2) (let ((a (list 2))) (quasiquote (1 (unquote-splicing a)))))
     731(f (eval '(let ((a 1))                  ; a is not a list
     732            (quasiquote (1 (unquote-splicing a))))))
     733(f (eval '(let ((a (list 1))
     734                (b (list 2)))
     735            (quasiquote (1 (unquote-splicing a b)))))) ; > 1 arg
     736
     737;; level counting
     738(define x (list 1 2))
     739
     740;; Testing R5RS-compliance:
     741(t '(quasiquote (unquote (1 2)))
     742   (quasiquote (quasiquote (unquote (unquote x)))))
     743(t '(quasiquote (unquote-splicing (1 2)))
     744   (quasiquote (quasiquote (unquote-splicing (unquote x)))))
     745(t '(quasiquote (unquote 1 2))
     746   (quasiquote (quasiquote (unquote (unquote-splicing x)))))
     747(t 'x
     748   (quasiquote (unquote (quasiquote x))))
     749(t '(quasiquote (unquote-splicing (quasiquote (unquote x))))
     750   (quasiquote (quasiquote (unquote-splicing (quasiquote (unquote x))))))
     751(t '(quasiquote (unquote (quasiquote (unquote-splicing x))))
     752   (quasiquote (quasiquote (unquote (quasiquote (unquote-splicing x))))))
     753(t '(quasiquote (unquote (quasiquote (unquote (1 2)))))
     754   (quasiquote (quasiquote (unquote (quasiquote (unquote (unquote x)))))))
     755
     756;; The following are explicitly left undefined by R5RS. For consistency
     757;; we define any unquote-(splicing) or quasiquote that occurs in the CAR of
     758;; a pair to decrease, respectively increase the level count by one.
     759 
     760(t '(quasiquote . #(1 (unquote x) 3))   ; cdr is not a pair
     761   (quasiquote (quasiquote . #(1 (unquote x) 3))))
     762(t '(quasiquote #(1 (unquote x) 3))     ; cdr is a list of one
     763   (quasiquote (quasiquote #(1 (unquote x) 3))))
     764(t '(quasiquote a #(1 (unquote x) 3) b) ; cdr is longer
     765   (quasiquote (quasiquote a #(1 (unquote x) 3) b)))
     766
     767(t '(quasiquote (unquote . #(1 (1 2) 3))) ; cdr is not a pair
     768   (quasiquote (quasiquote (unquote . #(1 (unquote x) 3)))))
     769(t '(quasiquote (unquote #(1 (1 2) 3))) ; cdr is a list of one
     770   (quasiquote (quasiquote (unquote #(1 (unquote x) 3)))))
     771(t '(quasiquote (unquote a #(1 (1 2) 3) b)) ; cdr is longer
     772   (quasiquote (quasiquote (unquote a #(1 (unquote x) 3) b))))
     773
     774(t '(quasiquote (unquote-splicing . #(1 (1 2) 3))) ; cdr is not a pair
     775   (quasiquote (quasiquote (unquote-splicing . #(1 (unquote x) 3)))))
     776(t '(quasiquote (unquote-splicing #(1 (1 2) 3))) ; cdr is a list of one
     777   (quasiquote (quasiquote (unquote-splicing #(1 (unquote x) 3)))))
     778(t '(quasiquote (unquote-splicing a #(1 (1 2) 3) b)) ; cdr is longer
     779   (quasiquote (quasiquote (unquote-splicing a #(1 (unquote x) 3) b))))
     780
     781(t 'quasiquote (quasiquote quasiquote))
     782(t 'unquote (quasiquote unquote))
     783(t 'unquote-splicing (quasiquote unquote-splicing))
     784(t '(x quasiquote) (quasiquote (x quasiquote)))
     785; (quasiquote (x unquote)) is identical to (quasiquote (x . (unquote)))....
     786;; It's either this (error) or make all calls to unquote with more or less
     787;; than one argument resolve to a literal unquote.
     788(f (eval '(quasiquote (x unquote))))
     789(t '(x unquote-splicing) (quasiquote (x unquote-splicing)))
     790 No newline at end of file