/[gcl]/gcl/ansi-tests/make-load-form.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/make-load-form.lsp

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

revision 1.2 by pfdietz, Sat May 17 15:20:38 2003 UTC revision 1.3 by pfdietz, Sat May 17 18:20:10 2003 UTC
# Line 107  Line 107 
107               (notnot-mv methods))))               (notnot-mv methods))))
108      (%m))      (%m))
109    t)    t)
110    
111    ;;; User-defined methods
112    
113    (defclass make-load-form-class-04 ()
114      ((a :initarg :a) (b :initarg :b) (c :initarg :c)))
115    
116    (defmethod make-load-form ((obj make-load-form-class-04)
117                               &optional (env t))
118      (declare (ignore env))
119      (let ((newobj (gensym)))
120        `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04))))
121           ,@(loop for slot-name in '(a b c)
122                  when (slot-boundp obj slot-name)
123                  collect `(setf (slot-value ,newobj ',slot-name)
124                                 ',(slot-value obj slot-name)))
125           ,newobj)))
126    
127    (deftest make-load-form.13
128      (let* ((obj (make-instance 'make-load-form-class-04))
129             (obj2 (eval (make-load-form obj))))
130        (values
131         (eqt (class-of obj2) (class-of obj))
132         (map-slot-boundp* obj2 '(a b c))))
133      t (nil nil nil))
134    
135    (deftest make-load-form.14
136      (let* ((obj (make-instance 'make-load-form-class-04 :a 1 :b '(a b c) :c 'a))
137             (obj2 (eval (make-load-form obj))))
138        (values
139         (eqt (class-of obj2) (class-of obj))
140         (map-slot-boundp* obj2 '(a b c))
141         (map-slot-value obj2 '(a b c))))
142      t
143      (t t t)
144      (1 (a b c) a))
145    
146    (deftest make-load-form.15
147      (let* ((obj (make-instance 'make-load-form-class-04 :b '(a b c) :c 'a))
148             (obj2 (eval (make-load-form obj nil))))
149        (values
150         (eqt (class-of obj2) (class-of obj))
151         (map-slot-boundp* obj2 '(a b c))
152         (map-slot-value obj2 '(b c))))
153      t
154      (nil t t)
155      ((a b c) a))
156    
157    ;;; Additional tests will be in the files testing file compilation

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