diff options
author | Andy Wingo <wingo@pobox.com> | 2008-10-31 18:30:27 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-10-31 18:30:27 +0100 |
commit | 5192c9e89bc18e5f6b33741aceed66bf28d56823 (patch) | |
tree | 310910af43efadefca671bbadeb4f76144679a1e | |
parent | 1e4b834ab1821f272359e03712044a4793c5d529 (diff) | |
download | guile-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.scm | 41 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 10 |
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" |