blob: 054886581704696f20d4853c7b5bc2375b124e4f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
;;;; standard-hooks.lisp -- built-in hooks for standard def* macros
(in-package :testiere)
;;; COMMON FUNCTIONS
(defun standard-extractor (orig-form)
"A somewhat naive default test form extractor. Returns two values,
orig-form without test forms included, and a collection of test forms."
(loop
:for form :in orig-form
:when (and (listp form)
(eq :tests (first form)))
:append (cdr form) :into tests-forms
:else
:collect form :into defun-form
:finally (return (values defun-form tests-forms))))
(defun standard-form-key (form)
"The first is a list (MACRO NAME) that uniquely identifies the form
form which tests are being defined. NAME's package is the suite to
which the tests of FORM will be be added.
This form key function is sutable for Common Lisp definition macros."
(list (first form) (second form)))
;;; DEFSTRUCT
;; (defstruct moo
;; #+testiere
;; (:tests ...)
;; a b c)
(register-hook
'cl:defstruct
#'standard-form-key
#'standard-extractor)
;;; DEFCLASS
;; (defclass fooar ()
;; (slots...)
;; #+testiere
;; (:tests ...))
(defun defclass-restarts-expander (form)
(let* ((name (second form))
(restart-name (intern (format nil "UNBIND-CLASS-~a" (symbol-name name)))))
`((,restart-name
()
(setf (find-class ',name) nil)))))
(register-hook
'cl:defclass
#'standard-extractor
#'standard-form-key
#'defclass-restarts-expander)
;;; DEFMETHOD
;; (defmethod okwhat ((x moo) (y bar) z)
;; "Here's a method"
;; #+testiere
;; (:tests ...)
;; (flah (moo-blah x) (barbar y)))
(register-hook 'cl:defmethod #'standard-extractor #'standard-form-key)
;;; DEFUN
;; (defun add3 (x y z)
;; "Adds three thigns"
;; #+testiere
;; (:tests ...)
;; (+ x y z))
(defun defun-restarts-expander (form)
(let* ((name (second form))
(restart-name (intern (format nil "UNBIND-FUNCTION-~a" (symbol-name name)))))
`((,restart-name
()
(fmakunbound ',name)))))
(register-hook 'cl:defun #'standard-extractor #'standard-form-key #'defun-restarts-expander)
;;; DEFTYPE
;; (deftype optional-number ()
;; "Its a number, or not"
;; #+testiere
;; (:tests ...)
;; `(or number null))
(register-hook 'cl:deftype #'standard-extractor #'standard-form-key)
|
