summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-10-31 18:30:27 +0100
committerAndy Wingo <wingo@pobox.com>2008-10-31 18:30:27 +0100
commit5192c9e89bc18e5f6b33741aceed66bf28d56823 (patch)
tree310910af43efadefca671bbadeb4f76144679a1e
parent1e4b834ab1821f272359e03712044a4793c5d529 (diff)
downloadguile-5192c9e89bc18e5f6b33741aceed66bf28d56823.tar.gz
compile goops accessors. woot!
* oop/goops.scm: Define compiler hooks for dealing with @slot-ref and @slot-set!. (make-bound-check-get, make-get, make-set): Compile these indexed accessors instead of having them be closures. Probably slower for the memoizer, but faster for the vm... not sure what the perfect solution is. * test-suite/tests/goops.test ("defining classes"): Add a test that defining a class with accessors works (it didn't until I figured out that (@ (system base compile) compile) thing).
-rw-r--r--oop/goops.scm41
-rw-r--r--test-suite/tests/goops.test10
2 files changed, 45 insertions, 6 deletions
diff --git a/oop/goops.scm b/oop/goops.scm
index ac5c4ef3f..dd993ded2 100644
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -1055,17 +1055,48 @@
(vector-set! methods index m)
m)))))
-;; eval tricks are apparently to make the accessors as fast as possible
-;; for the evaluator. when goops gets vm-aware, this will be different.
+;; the idea is to compile the index into the procedure, for fastest
+;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
+(eval-case
+ ((load-toplevel compile-toplevel)
+ (use-modules ((language scheme translate) :select (define-scheme-translator))
+ ((system il ghil) :select (make-ghil-inline))
+ (system base pmatch))
+
+ ;; unfortunately, can't use define-inline because these are primitive
+ ;; syntaxen.
+ (define-scheme-translator @slot-ref
+ ((,obj ,index) (guard (integer? index)
+ (>= index 0) (< index max-fixnum))
+ (make-ghil-inline #f #f 'slot-ref
+ (list (retrans obj) (retrans index)))))
+
+ (define-scheme-translator @slot-set!
+ ((,obj ,index ,val) (guard (integer? index)
+ (>= index 0) (< index max-fixnum))
+ (make-ghil-inline #f #f 'slot-set
+ (list (retrans obj) (retrans index) (retrans val)))))))
+
+;; Irritatingly, we can't use `compile' here, as the module shadows
+;; the binding.
(define (make-bound-check-get index)
- (eval `(lambda (o) (@assert-bound-ref o ,index)) *goops-module*))
+ ((@ (system base compile) compile)
+ `(lambda (o) (let ((x (@slot-ref o ,index)))
+ (if (unbound? x)
+ (slot-unbound obj)
+ x)))
+ *goops-module*))
(define (make-get index)
- (eval `(lambda (o) (@slot-ref o ,index)) *goops-module*))
+ ((@ (system base compile) compile)
+ `(lambda (o) (@slot-ref o ,index))
+ *goops-module*))
(define (make-set index)
- (eval `(lambda (o v) (@slot-set! o ,index v)) *goops-module*))
+ ((@ (system base compile) compile)
+ `(lambda (o v) (@slot-set! o ,index v))
+ *goops-module*))
(define bound-check-get
(standard-accessor-method make-bound-check-get bound-check-get-methods))
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 713132a43..8861d23a9 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -173,7 +173,15 @@
(and (struct? x)
(eq? (struct-ref x 0) 'hello)
(eq? (struct-ref x 1) 'world)))
- (current-module)))))
+ (current-module)))
+
+ (pass-if "with accessors"
+ (eval '(define-class <qux> ()
+ (x #:accessor x #:init-value 123)
+ (z #:accessor z #:init-value 789))
+ (current-module))
+ (eval '(equal? (x (make <qux>)) 123) (current-module)))))
+
(with-test-prefix "defining generics"