Fix accessor struct field inlining
[bpt/guile.git] / test-suite / tests / goops.test
index f2ae2b7..1c6d33e 100644 (file)
@@ -1,6 +1,6 @@
 ;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 2015 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
   (pass-if "struct vtable"
     ;; Previously, `class-of' would fail for nameless structs, i.e., structs
     ;; for which `struct-vtable-name' is #f.
-    (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>)))
+    (is-a? (class-of (make-vtable
+                      (string-append standard-vtable-fields "prprpr")))
+           <class>)))
 
 
 (with-test-prefix "defining classes"
 
     (expect-fail "bad init-thunk"
                 (begin
-                   ;; Currently UPASSing because we can't usefully get
-                   ;; any arity information out of interpreted
-                   ;; procedures. A FIXME I guess.
-                   (throw 'unresolved)
                    (catch #t
                      (lambda ()
                        (eval '(define-class <foo> ()
                        (x #:accessor x #:init-value 123)
                        (z #:accessor z #:init-value 789))
                     (current-module))
-              (eval '(equal? (x (make <qux>)) 123) (current-module)))))
-     
+              (eval '(equal? (x (make <qux>)) 123) (current-module)))
+
+     (pass-if-exception "cannot redefine fields of <class>"
+       '(misc-error . "cannot be redefined")
+       (eval '(begin
+                (define-class <test-class> (<class>) 
+                  name) 
+                (make <test-class>))
+             (current-module)))))
 
 (with-test-prefix "defining generics"
 
       (eval '(define-generic foo) (current-module))
       (eval '(and (is-a? foo <generic>)
                  (null? (generic-function-methods foo)))
-           (current-module)))))
+           (current-module)))
+
+    (pass-if-exception "getters do not have setters"
+                       exception:wrong-type-arg
+                       (eval '(setter foo) (current-module)))))
 
 (with-test-prefix "defining methods"
 
                  (null? (generic-function-methods foo-1)))
            (current-module)))
 
+    (pass-if "accessors have setters"
+      (procedure? (eval '(setter foo-1) (current-module))))
+
     (pass-if "overwriting a top-level binding to a non-accessor"
       (eval '(define (foo) #f) (current-module))
       (eval '(define-accessor foo) (current-module))
             (x bar)
             (set! (x bar) 2)
             (equal? (reverse z)
-                    '(before-ref before-set! 1 before-ref after-ref
-                      after-set! 1 1 before-ref after-ref
-                      before-set! 2 before-ref after-ref after-set! 2 2)))
+                    '(before-set! 1 before-ref after-ref
+                       after-set! 1 1 before-ref after-ref
+                       before-set! 2 before-ref after-ref after-set! 2 2)))
          (current-module))))
 
 (use-modules (oop goops composite-slot))
                      exception:no-applicable-method
     (eval '(quxy 1)
          (current-module))))
+
+(with-test-prefix "foreign slots"
+  (define-class <foreign-test> ()
+    (a #:init-keyword #:a #:class <foreign-slot>
+       #:accessor test-a)
+    (b #:init-keyword #:b #:init-form 3 #:class <foreign-slot>
+       #:accessor test-b))
+
+  (pass-if-equal "constructing, no initargs"
+      '(0 3)
+    (let ((x (make <foreign-test>)))
+      (list (slot-ref x 'a)
+            (slot-ref x 'b))))
+
+  (pass-if-equal "constructing, initargs"
+      '(1 2)
+    (let ((x (make <foreign-test> #:a 1 #:b 2)))
+      (list (slot-ref x 'a)
+            (slot-ref x 'b))))
+
+  (pass-if-equal "getters"
+      '(0 3)
+    (let ((x (make <foreign-test>)))
+      (list (test-a x) (test-b x))))
+
+  (pass-if-equal "setters"
+      '(10 20)
+    (let ((x (make <foreign-test>)))
+      (set! (test-a x) 10)
+      (set! (test-b x) 20)
+      (list (test-a x) (test-b x))))
+
+  (pass-if-exception "out of range"
+      exception:out-of-range
+    (make <foreign-test> #:a (ash 1 64))))
+
+(with-test-prefix "#:each-subclass"
+  (let* ((<subclass-allocation-test>
+          (class ()
+            (test #:init-value '() #:allocation #:each-subclass)
+            #:name '<subclass-allocation-test>))
+         (a (make <subclass-allocation-test>)))
+    (pass-if-equal '() (slot-ref a 'test))
+    (let ((b (make <subclass-allocation-test>)))
+      (pass-if-equal '() (slot-ref b 'test))
+      (slot-set! a 'test 100)
+      (pass-if-equal 100 (slot-ref a 'test))
+      (pass-if-equal 100 (slot-ref b 'test))
+
+      ;; #:init-value of the class shouldn't reinitialize slot when
+      ;; instances are allocated.
+      (make <subclass-allocation-test>)
+
+      (pass-if-equal 100 (slot-ref a 'test))
+      (pass-if-equal 100 (slot-ref b 'test))
+
+      (let ((<test-subclass>
+             (class (<subclass-allocation-test>))))
+        (pass-if-equal 100 (slot-ref a 'test))
+        (pass-if-equal 100 (slot-ref b 'test))
+        (let ((c (make <test-subclass>)))
+          (pass-if-equal 100 (slot-ref a 'test))
+          (pass-if-equal 100 (slot-ref b 'test))
+          (pass-if-equal '() (slot-ref c 'test))
+          (slot-set! c 'test 200)
+          (pass-if-equal 200 (slot-ref c 'test))
+
+          (make <test-subclass>)
+
+          (pass-if-equal 100 (slot-ref a 'test))
+          (pass-if-equal 100 (slot-ref b 'test))
+          (pass-if-equal 200 (slot-ref c 'test)))))))
+
+(with-test-prefix "accessor slots"
+  (let* ((a-accessor (make-accessor 'a))
+         (b-accessor (make-accessor 'b))
+         (<a> (class ()
+                (a #:init-keyword #:a #:accessor a-accessor)
+                #:name '<a>))
+         (<b> (class ()
+                (b #:init-keyword #:b #:accessor b-accessor)
+                #:name '<b>))
+         (<ab> (class (<a> <b>) #:name '<ab>))
+         (<ba> (class (<b> <a>) #:name '<ba>))
+         (<cab> (class (<ab>)
+                  (a #:init-keyword #:a)
+                  #:name '<cab>))
+         (<cba> (class (<ba>)
+                  (a #:init-keyword #:a)
+                  #:name '<cba>))
+         (a (make <a> #:a 'a))
+         (b (make <b> #:b 'b))
+         (ab (make <ab> #:a 'a #:b 'b))
+         (ba (make <ba> #:a 'a #:b 'b))
+         (cab (make <cab> #:a 'a #:b 'b))
+         (cba (make <cba> #:a 'a #:b 'b)))
+    (pass-if-equal "a accessor on a" 'a (a-accessor a))
+    (pass-if-equal "a accessor on ab" 'a (a-accessor ab))
+    (pass-if-equal "a accessor on ba" 'a (a-accessor ba))
+    (pass-if-equal "a accessor on cab" 'a (a-accessor cab))
+    (pass-if-equal "a accessor on cba" 'a (a-accessor cba))
+    (pass-if-equal "b accessor on a" 'b (b-accessor b))
+    (pass-if-equal "b accessor on ab" 'b (b-accessor ab))
+    (pass-if-equal "b accessor on ba" 'b (b-accessor ba))
+    (pass-if-equal "b accessor on cab" 'b (b-accessor cab))
+    (pass-if-equal "b accessor on cba" 'b (b-accessor cba))))