Changeset 9841 for trunk/tests


Ignore:
Timestamp:
Jun 27, 2008, 5:03:48 PM (11 years ago)
Author:
gz
Message:

Add a bunch of basic advice tests so at least can tell if totally break it.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/tests/ansi-tests/ccl.lsp

    r9766 r9841  
    271271  foo)
    272272
     273;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     274;;; ADVISE
     275
     276(defun function-to-advise (x) (car x))
     277(defun another-function-to-advise (x) (cdr x))
     278(defun (setf function-to-advise) (val arg) (setf (car arg) val))
     279
     280(declaim (notinline function-to-advise
     281                    another-function-to-advise
     282                    (setf function-to-advise)))
     283
     284(defvar *advise-var* nil)
     285
     286
     287(deftest advise.1
     288  (progn
     289    (ccl:unadvise t)
     290    (function-to-advise '(a)))
     291  a)
     292
     293(deftest advise.2
     294  (progn
     295    (ccl:unadvise t)
     296    (ccl:advise function-to-advise (return 'advise.2))
     297    (function-to-advise '(b)))
     298  advise.2)
     299
     300(deftest advise.3
     301  (progn
     302    (ccl:unadvise t)
     303    (ccl:advise function-to-advise 'advised.3 :when :around :name test)
     304    (assert (eq 'advised.3 (function-to-advise '(a))))
     305    (prog1 (ccl:advisedp t)
     306      (ccl:unadvise t)
     307      (assert (null (ccl:advisedp t)))))
     308  ((function-to-advise :around test)))
     309
     310
     311(deftest advise.4
     312  (progn
     313    (ccl:unadvise t)
     314    (ccl:advise function-to-advise (return 'advise.4) :name test)
     315    (handler-bind ((warning #'muffle-warning))
     316      (ccl:advise function-to-advise (return 'readvised) :name test))
     317    (prog1 (ccl:advisedp t)
     318      (ccl:unadvise t)
     319      (assert (null (ccl:advisedp t)))))
     320  ((function-to-advise :before test)))
     321
     322(deftest advise.4a
     323  (progn
     324    (ccl:unadvise t)
     325    (setq *advise-var* '(none))
     326    (ccl:advise function-to-advise (push 'advise.4a *advise-var*) :name test)
     327    (handler-bind ((warning #'muffle-warning))
     328      (ccl:advise function-to-advise (push 'readvise.4a *advise-var*) :name test))
     329    (assert (eq (function-to-advise '(c)) 'c))
     330    *advise-var*)
     331  (readvise.4a none))
     332
     333(deftest advise.5
     334  (progn
     335    (ccl:unadvise t)
     336    (setq *advise-var* '(none))
     337    (ccl:advise (setf function-to-advise) (push 'advise.5 *advise-var*))
     338    (prog1 (ccl:advisedp t)
     339      (ccl:unadvise t)
     340      (assert (null (ccl:advisedp t)))))
     341  (((setf function-to-advise) :before nil)))
     342
     343(deftest advise.6
     344  (progn
     345    (ccl:unadvise t)
     346    (setq *advise-var* '(none))
     347    (ccl:advise (setf function-to-advise) (push 'advise.6 *advise-var*))
     348    (handler-bind ((warning #'muffle-warning))
     349      (ccl:advise (setf function-to-advise) (push 'readvise.6 *advise-var*)))
     350    (prog1 (ccl:advisedp t)
     351      (ccl:unadvise t)
     352      (assert (null (ccl:advisedp t)))))
     353  (((setf function-to-advise) :before nil)))
     354
     355(deftest advise.6a
     356  (progn
     357    (ccl:unadvise t)
     358    (setq *advise-var* '(none))
     359    (ccl:advise (setf function-to-advise) (push 'advise.6a *advise-var*) :when :after)
     360    (handler-bind ((warning #'muffle-warning))
     361      (ccl:advise (setf function-to-advise) (push 'readvise.6a *advise-var*) :when :after))
     362    (let ((x (list nil)))
     363      (list* (setf (function-to-advise x) 17)
     364             (car x)
     365             *advise-var*)))
     366  (17 17 readvise.6a none))
     367
     368(deftest advise.7
     369  (progn
     370    (ccl:unadvise t)
     371    (setq *advise-var* '(none))
     372    (let ((x (list nil)))
     373      (assert (eql (setf (function-to-advise x) 'a) 'a))
     374      (assert (equal x '(a)))
     375      *advise-var*))
     376  (none))
     377
     378(deftest advise.8
     379  (progn
     380    (ccl:unadvise t)
     381    (setq *advise-var* '(none))
     382    (ccl:advise (setf function-to-advise) (push 'advise.8 *advise-var*))
     383    (let ((x (list nil)))
     384      (assert (eql (setf (function-to-advise x) 'a) 'a))
     385      (assert (equal x '(a)))
     386      *advise-var*))
     387  (advise.8 none))
     388
     389(deftest advise.9
     390  (progn
     391    (ccl:unadvise t)
     392    (setq *advise-var* '(none))
     393    (ccl:advise function-to-advise (push 'advise.9 *advise-var*))
     394    (ccl:advise another-function-to-advise (push 'another-advise.9 *advise-var*))
     395    (assert (eql (function-to-advise '(b)) 'b))
     396    (assert (eql (another-function-to-advise '(c . d)) 'd))
     397    (assert (equal *advise-var* '(another-advise.9 advise.9 none)))
     398    (prog1
     399        (sort (copy-list (ccl:advisedp t))
     400              #'(lambda (k1 k2) (string< (princ-to-string k1)
     401                                         (princ-to-string k2))))
     402      (ccl:unadvise t)))
     403  ((another-function-to-advise :before nil) (function-to-advise :before nil)))
     404
     405(deftest advise.10
     406  (progn
     407    (ccl:unadvise t)
     408    (setq *advise-var* '(none))
     409    (assert (null (ccl:advisedp t)))
     410    (ccl:advise function-to-advise (push 'advise.10 *advise-var*))
     411    (ccl:unadvise function-to-advise)
     412    (assert (null (ccl:advisedp t)))
     413    (handler-bind ((warning #'muffle-warning)) (ccl:unadvise function-to-advise))
     414    (assert (null (ccl:advisedp t)))
     415    nil)
     416  nil)
     417
     418(deftest advise.11
     419  (progn
     420    (ccl:unadvise t)
     421    (ccl:advise function-to-advise  (return 17))
     422    (ccl:advise another-function-to-advise (return 18))
     423    (ccl:unadvise function-to-advise)
     424    (ccl:unadvise another-function-to-advise)
     425    (ccl:advisedp t))
     426  nil)
     427
     428;;; advising a generic function
     429
     430(declaim (notinline generic-function-to-advise))
     431
     432(deftest advise.12
     433  (progn
     434    (ccl:unadvise t)
     435    (setq *advise-var* '(none))
     436    (eval '(defgeneric generic-function-to-advise (x y)))
     437    (ccl:advise generic-function-to-advise (push 'advise.12 *advise-var*))
     438    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
     439  ((generic-function-to-advise :before nil)))
     440
     441(deftest advise.13
     442  (progn
     443    (ccl:unadvise t)
     444    (setq *advise-var* '(none))
     445    (eval '(defgeneric generic-function-to-advise (x y)))
     446    (ccl:advise generic-function-to-advise (push 'advise.13 *advise-var*))
     447    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
     448    (prog1 (ccl:advisedp t) (ccl:unadvise t)))
     449  ((generic-function-to-advise :before nil)))
     450
     451(deftest advise.14
     452  (progn
     453    (ccl:unadvise t)
     454    (setq *advise-var* '(none))
     455    (eval '(defgeneric generic-function-to-advise (x y)))
     456    (ccl:advise generic-function-to-advise (push 'advise.14 *advise-var*))
     457    (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil))
     458    (assert (null (generic-function-to-advise 'a 'b)))
     459    (assert (equal *advise-var* '(advise.14 none)))
     460    (prog1
     461        (ccl:advisedp t)
     462      (ccl:unadvise generic-function-to-advise)
     463      (assert (null (ccl:advisedp t)))))
     464  ((generic-function-to-advise :before nil)))
     465
     466(declaim (notinline generic-function-to-advise2))
     467
     468(deftest advise.15
     469  (progn
     470    (ccl:unadvise t)
     471    (setq *advise-var* '(none))
     472    (let* ((gf (eval '(defgeneric generic-function-to-advise2 (x y))))
     473           (m (eval '(defmethod generic-function-to-advise2
     474                       ((x integer)(y integer))
     475                       :foo))))
     476      (eval '(defmethod generic-function-to-advise2
     477               ((x symbol)(y symbol)) :bar))
     478      (assert (eql (generic-function-to-advise2 1 2) :foo))
     479      (assert (eql (generic-function-to-advise2 'a 'b) :bar))
     480      (ccl:advise generic-function-to-advise2 (push 'advise.15 *advise-var*))
     481      (assert (equal (ccl:advisedp t) '((generic-function-to-advise2 :before nil))))
     482      (remove-method gf m)
     483      (prog1 (ccl:advisedp t) (ccl:unadvise t))))
     484  ((generic-function-to-advise2 :before nil)))
     485
     486
     487(deftest advise.16
     488  (progn
     489    (ccl:unadvise t)
     490    (setq *advise-var* '(none))
     491    (ccl:advise function-to-advise (push 'advise.16-1 *advise-var*) :name test-1)
     492    (ccl:advise function-to-advise (push 'advise.16-2 *advise-var*) :name test-2)
     493    (prog1 (cons (function-to-advise '(foo)) *advise-var*) (ccl:unadvise t)))
     494  (foo advise.16-1 advise.16-2 none))
     495
     496(deftest advise.17
     497  (progn
     498    (ccl:unadvise t)
     499    (setq *advise-var* '(none))
     500    (untrace)
     501    (ccl:advise function-to-advise (push 'advise.17-1 *advise-var*) :name test-1)
     502    (trace function-to-advise)
     503    (ccl:advise function-to-advise (push 'advise.17-2 *advise-var*) :name test-2)
     504    (prog1
     505        (list (not (equal "" (with-output-to-string (*trace-output*)
     506                               (function-to-advise '(foo)))))
     507              *advise-var*
     508              (ccl:unadvise function-to-advise :name test-1)
     509              (not (equal "" (with-output-to-string (*trace-output*)
     510                               (function-to-advise '(bar)))))
     511              *advise-var*
     512              (untrace)
     513              (with-output-to-string (*trace-output*)
     514                (function-to-advise '(bar)))
     515              *advise-var*)
     516      (ccl:unadvise t)
     517      (untrace)))
     518  (t (advise.17-1 advise.17-2 none) ((function-to-advise :before test-1))
     519     t (advise.17-2 advise.17-1 advise.17-2 none) (function-to-advise) ""
     520     (advise.17-2 advise.17-2 advise.17-1 advise.17-2 none)))
     521
     522
     523(deftest advise.18
     524  (progn
     525    (ccl:unadvise t)
     526    (setq *advise-var* '(none))
     527    (untrace)
     528    (fmakunbound 'generic-function-to-advise.18)
     529    (eval '(defgeneric generic-function-to-advise.18 (x y)))
     530    (eval '(defmethod generic-function-to-advise.18 ((x integer)(y integer)) :foo))
     531    (eval '(defmethod generic-function-to-advise.18 ((x symbol)(y symbol)) :bar))
     532    (ccl:advise generic-function-to-advise.18 (push 'advise.18-1 *advise-var*) :name test-1)
     533    (trace generic-function-to-advise.18)
     534    (ccl:advise function-to-advise.18 (push 'advise.18-2 *advise-var*) :name test-2)
     535    (prog1
     536        (list (not (equal "" (with-output-to-string (*trace-output*)
     537                               (assert (eq :bar (generic-function-to-advise.18 'a 'b))))))
     538              *advise-var*
     539              (ccl:unadvise generic-function-to-advise.18 :name test-1)
     540              (not (equal "" (with-output-to-string (*trace-output*)
     541                               (assert (eq :foo (generic-function-to-advise.18 1 2))))))
     542              *advise-var*
     543              (untrace)
     544              (with-output-to-string (*trace-output*)
     545                (generic-function-to-advise.18 'x 'y))
     546              *advise-var*)
     547      (ccl:unadvise t)
     548      (untrace)))
     549  (t (advise.18-1 advise.18-2 none) ((function-to-advise :before test-1))
     550     t (advise.18-2 advise.18-1 advise.18-2 none) (generic-function-to-advise.18) ""
     551     (advise.18-2 advise.18-2 advise.18-1 advise.18-2 none)))
     552
     553
Note: See TracChangeset for help on using the changeset viewer.