;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Apr 20 12:33:02 2003
;;;; Contains: Tests of DEFINE-COMPILER-MACRO



;;; Need to add non-error tests

(deftest define-compiler-macro.error.1
  (signals-error (funcall (macro-function 'define-compiler-macro))
                 program-error)
  t)

(deftest define-compiler-macro.error.2
  (signals-error (funcall (macro-function 'define-compiler-macro)
                           '(definee-compiler-macro nonexistent-function ()))
                 program-error)
  t)

(deftest define-compiler-macro.error.3
  (signals-error (funcall (macro-function 'define-compiler-macro)
                           '(definee-compiler-macro nonexistent-function ())
                           nil nil)
                 program-error)
  t)

;;; Non-error tests

(deftest define-compiler-macro.1
  (let* ((sym (gensym))
         (macro-def-form
          `(define-compiler-macro ,sym (x y)
             (declare (special *x*))
             (setf *x* t)
             `(+ ,x ,y 1)))
         (fun-def-form
          `(defun ,sym (x y) (+ x y 1))))
    (values
     (equalt (list sym) (multiple-value-list (eval fun-def-form)))
     (equalt (list sym) (multiple-value-list (eval macro-def-form)))
     (notnot (typep (compiler-macro-function sym) 'function))
     (eval `(,sym 6 19))
     (let ((fn (compile nil `(lambda (a b) (,sym a b)))))
       (let ((*x* nil))
         (declare (special *x*))
         (list (funcall fn 12 123) *x*)))))
  t t t 26 (136 nil))

(deftest define-compiler-macro.2
  (let* ((sym (gensym))
         (macro-def-form
          `(define-compiler-macro ,sym (&whole form &rest args)
             (declare (special *x*) (ignore args))
             (setf *x* t)
             (return-from ,sym form)))
         (fun-def-form
          `(defun ,sym (x) x)))
    (values
     (equalt (list sym) (multiple-value-list (eval fun-def-form)))
     (equalt (list sym) (multiple-value-list (eval macro-def-form)))
     (notnot (typep (compiler-macro-function sym) 'function))
     (eval `(,sym 'a))
     (let ((fn (compile nil `(lambda (a) (,sym a)))))
       (let ((*x* nil))
         (declare (special *x*))
         (list (funcall fn 'b) *x*)))))
  t t t a (b nil))

(deftest define-compiler-macro.3
  (let* ((sym (gensym))
         (macro-def-form
          `(define-compiler-macro ,sym (&whole form &rest args)
             (declare (special *x*) (ignore args))
             (setf *x* t)
             (return-from ,sym form)))
         (ordinary-macro-def-form
          `(defmacro ,sym (x) x)))
    (values
     (equalt (list sym) (multiple-value-list (eval ordinary-macro-def-form)))
     (equalt (list sym) (multiple-value-list (eval macro-def-form)))
     (notnot (typep (compiler-macro-function sym) 'function))
     (eval `(,sym 'a))
     (let ((fn (compile nil `(lambda (a) (,sym a)))))
       (let ((*x* nil))
         (declare (special *x*))
         (list (funcall fn 'b) *x*)))))
  t t t a (b nil))

;;; Compiler macros on setf functions

(deftest define-compiler-macro.4
  (let* ((sym (gensym))
         (fun-def-form `(defun ,sym (x) (car x)))
         (setf-fun-def-form `(defun (setf ,sym) (newval x) (setf (car x) newval)))
         (setf-compiler-macro-def-form
          `(define-compiler-macro (setf ,sym) (newval x)
             (declare (special *x*))
             (setf *x* t)
             (return-from ,sym `(setf (car ,x) ,newval)))))
    (values
     (equalt (list sym) (multiple-value-list (eval fun-def-form)))
     (equalt `((setf ,sym)) (multiple-value-list (eval setf-fun-def-form)))
     (equalt `((setf ,sym)) (multiple-value-list (eval setf-compiler-macro-def-form)))
     (notnot (typep (compiler-macro-function `(setf ,sym)) 'function))
     (eval `(,sym (list 'a 'b)))
     (eval `(let ((arg (list 1 2)))
              (list (setf (,sym arg) 'z) arg)))
     (let ((fn (compile nil `(lambda (u v) (setf (,sym u) v)))))
       (let ((*x* nil)
             (arg (list 1 2)))
         (declare (special *x*))
         (list (funcall fn arg 'y) arg)))))
  t t t t a (z (z 2)) (y (y 2)))

;;; Test of documentation

(deftest define-compiler-macro.5
  (let* ((sym (gensym))
         (form `(define-compiler-macro ,sym (x) "DCM.5" x))
         (form2 `(defun ,sym (x) "DCM.5-WRONG" x)))
    (eval form)
    (eval form2)
    (or (documentation sym 'compiler-macro) "DCM.5"))
  "DCM.5")

(deftest define-compiler-macro.6
  (let* ((sym (gensym))
         (form `(define-compiler-macro ,sym (x) "DCM.6" x))
         (form2 `(defun ,sym (x) "DCM.6-WRONG" x)))
    (eval form2)
    (eval form)
    (or (documentation sym 'compiler-macro) "DCM.6"))
  "DCM.6")

;;; NOTINLINE turns off a compiler macro

(deftest define-compiler-macro.7
  (let* ((sym (gensym))
         (form `(define-compiler-macro ,sym (x y)
                  (declare (special *x*))
                  (setf *x* :bad)
                  `(list ,x ,y)))
         (form2 `(defun ,sym (x y) (list x y))))
    (eval form)
    (eval form2)
    (compile sym)
    (let ((*x* :good))
      (declare (special *x*))
      (values
       (funcall (compile nil `(lambda (a b)
                                (declare (notinline ,sym))
                                (,sym a b)))
                5 11)
       *x*)))
  (5 11) :good)

(deftest define-compiler-macro.8
  (let* ((sym (gensym))
         (form `(define-compiler-macro ,sym (x y)
                  (declare (special *x*))
                  (setf *x* :bad)
                  `(list ,x ,y)))
         (form2 `(defmacro ,sym (x y) `(list ,x ,y))))
    (eval form)
    (eval form2)
    (let ((*x* :good))
      (declare (special *x*))
      (values
       (funcall (compile nil `(lambda (a b)
                                (declare (notinline ,sym))
                                (,sym a b)))
                7 23)
       *x*)))
  (7 23) :good)