tests/backq.impure.lisp

   1 ;;;; tests of backquote readmacro
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package "CL-USER")
  15
  16 (defparameter *qq* '(*rr* *ss*))
  17 (defparameter *rr* '(3 5))
  18 (defparameter *ss* '(4 6))
  19
  20 (defun *rr* (x)
  21   (reduce #'* x))
  22
  23 (defparameter *x* '(a b))
  24 (defparameter *y* '(c))
  25 (defparameter *p* '(append *x* *y*))
  26 (defparameter *q* '((append *x* *y*) (list 'sqrt 9)))
  27 (defparameter *r* '(append *x* *y*))
  28 (defparameter *s* '((append *x* *y*)))
  29
  30 (defun test-double-backquote (expression value)
  31   (format t "~&Testing: ~A... " expression)
  32   (assert (equal (eval (eval (read-from-string expression)))
  33                  value))
  34   (format t "Ok. Look at PPRINTed version: ")
  35   (pprint (read-from-string expression)))
  36
  37 (defparameter *backquote-tests*
  38   '(("``(,,*QQ*)" . (24))
  39     ("``(,@,*QQ*)" . 24)
  40     ("``(,,@*QQ*)" . ((3 5) (4 6)))
  41     ("``(FOO ,,*P*)" . (foo (a b c)))
  42     ("``(FOO ,,@*Q*)" . (foo (a b c) (sqrt 9)))
  43     ("``(FOO ,',*R*)" . (foo (append *x* *y*)))
  44     ("``(FOO ,',@*S*)" . (foo (append *x* *y*)))
  45     ("``(FOO ,@,*P*)" . (foo a b c))
  46     ("``(FOO ,@',*R*)" . (foo append *x* *y*))
  47     ;; The following expression produces different result under LW.
  48     ("``(FOO . ,,@*Q*)" . (foo a b c sqrt 9))
  49     ;; These three did not work.
  50     ("``(FOO ,@',@*S*)" . (foo append *x* *y*))
  51     ("``(FOO ,@,@*Q*)" . (foo a b c sqrt 9))
  52     ("``(,@,@*QQ*)" . (3 5 4 6))))
  53
  54 (mapc (lambda (test)
  55         (test-double-backquote (car test) (cdr test)))
  56       *backquote-tests*)
  57
  58 ;;; success
  59 (quit :unix-status 104)