/[gcl]/gcl/ansi-tests/defclass-aux.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/defclass-aux.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by pfdietz, Sat Mar 29 03:55:28 2003 UTC revision 1.3 by pfdietz, Wed Apr 2 13:21:05 2003 UTC
# Line 13  Line 13 
13  (defparameter *defclass-slot-writers* nil)  (defparameter *defclass-slot-writers* nil)
14  (defparameter *defclass-slot-accessors* nil)  (defparameter *defclass-slot-accessors* nil)
15    
16    (defstruct my-class
17      (name nil :type symbol)
18      (direct-superclass-names nil :type list)
19      (slots nil :type list)
20      (default-initargs nil :type list)
21      (metaclass 'standard-class :type symbol)
22      (documentation nil :type (or null string))
23      )
24    
25    (defstruct my-slot
26      (name nil :type symbol)
27      (has-initform nil :type boolean)
28      initform
29      (initargs nil :type list)
30      (documentation nil :type (or null string))
31      (readers nil :type list)
32      (writers nil :type list)
33      (accessors nil :type list)
34      (allocation :instance :type (member :instance :class))
35      (type t)
36      )
37    
38    (defparameter *my-classes* (make-hash-table)
39      "Hash table mapping names of classes defined using DEFCLASS-WITH-TESTS
40       to their my-class objects.")
41    
42    (defun find-my-class (class-name)
43      (gethash class-name *my-classes*))
44    
45  (defmacro defclass-with-tests  (defmacro defclass-with-tests
46    (&whole args    (&whole args
47            class-name superclasses slot-specifiers            class-name superclasses slot-specifiers
# Line 35  Line 64 
64    (assert (eql (length class-options)    (assert (eql (length class-options)
65                 (length (remove-duplicates class-options))))                 (length (remove-duplicates class-options))))
66    
67    (let* ((default-initargs (second (assoc :default-initargs class-options)))    (let* ((default-initargs (rest (assoc :default-initargs class-options)))
68           (metaclass (or (second (assoc :metaclass class-options))           (metaclass (or (second (assoc :metaclass class-options))
69                          'standard-class))                          'standard-class))
70           (doc (second (assoc :documentation class-options)))           (doc (second (assoc :documentation class-options)))
# Line 62  Line 91 
91                  append (collect-properties slot-option :accessor)))                  append (collect-properties slot-option :accessor)))
92           (allocations           (allocations
93            (loop for slot-option in slot-options            (loop for slot-option in slot-options
94                  collect (or (get :allocation slot-option)                  collect (or (get slot-option :allocation)
95                              :instance)))                              :instance)))
96           (initargs           (initargs
97            (loop for slot-option in slot-options            (loop for slot-option in slot-options
# Line 87  Line 116 
116      (setf *defclass-slot-accessors*      (setf *defclass-slot-accessors*
117            (append accessors *defclass-slot-accessors*))            (append accessors *defclass-slot-accessors*))
118    
119        ;;; Store away information about the class and its slots
120        ;;; in a my-class object and associated my-slot objects.
121        
122        (let* ((my-slots
123               (loop for name in slot-names
124                     for slot-option in slot-options
125                     for readers = (collect-properties slot-option :reader)
126                     for writers = (collect-properties slot-option :writer)
127                     for accessors = (collect-properties slot-option :accessor)
128                     for documentation = (getf slot-option :documentation)
129                     for initarg-list in initargs
130                     for type-list in types
131                     for initform-list in initforms
132                     for allocation in allocations
133                     collect
134                     (make-my-slot
135                      :name name
136                      :has-initform (notnot initform-list)
137                      :initform (first initform-list)
138                      :documentation documentation
139                      :readers readers
140                      :writers writers
141                      :accessors accessors
142                      :type (if type-list (first type-list) t)
143                      )))
144              (my-class-obj
145               (make-my-class :name class-name
146                              :direct-superclass-names superclasses
147                              :default-initargs default-initargs
148                              :documentation doc
149                              :metaclass metaclass
150                              :slots my-slots)))
151          (setf (gethash class-name *my-classes*) my-class-obj))
152    
153      `(progn      `(progn
154    
155         (eval-when (load eval compile)         (eval-when (load eval compile)
# Line 113  Line 176 
176                    t))                    t))
177    
178         (deftest ,(make-defclass-test-name class-name         (deftest ,(make-defclass-test-name class-name
179                                            "-INSTANCES-CLASS-IS-THIS-ONE")                                            "-ALLOCATE-INSTANCE")
180           (let ((class (find-class ',class-name)))           (defclass-allocate-instance-test ',class-name ',slot-names)
181             (eqlt (class-of (allocate-instance class)) class))           nil)
          t)  
182    
183         )))         )))
184    
185    (defun defclass-allocate-instance-test (class-name slot-names)
186      (let* ((class (find-class class-name))
187             (instance (allocate-instance class)))
188        (append
189         (unless (eql (class-of instance) class)
190           (list (list 'not-instance-of class-name)))
191         (loop for slot in slot-names
192               when (slot-boundp instance slot)
193               collect (list 'is-bound slot))
194         (loop for slot in slot-names
195               (unless (equal (multiple-value-list
196                               (notnot-mv (slot-exists-p instance slot)))
197                              '(t))
198                 (list 'does-not-exist slot)))
199         (let ((bad-slot #:foo))
200           (when (slot-exists-p instance bad-slot)
201             (list (list 'should-not-exist bad-slot))))
202         )))
203      
204  (defmacro generate-slot-tests ()  (defmacro generate-slot-tests ()
205    "Generate generic tests from the read/writer/accessor functions    "Generate generic tests from the read/writer/accessor functions
206     for slots from defclass-with-tests."     for slots from defclass-with-tests."
# Line 142  Line 223 
223                                      'generic-function))                                      'generic-function))
224                          '(,sym))))                          '(,sym))))
225           nil))))           nil))))
226    
227    #|
228    
229    (defun compute-class-precedence-list (class-name)
230      "Compute the class precdence list for classes defined using
231       DEFCLASS-WITH-TESTS."
232      (let ((classes nil)
233            (classes-to-consider class-name))
234        ;; Find all classes
235    
236    |#
237        

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26