summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-11-30 16:40:17 +0100
committerAndy Wingo <wingo@pobox.com>2013-11-30 18:46:14 +0100
commit4d6a7ac6ad5ea51927aec92f85b8526340a73270 (patch)
treec864dca62467f9300738ec0e3ff654d6da4a15a4
parent23e2e78067787da3dabfded1b3a3f7a10905b4a8 (diff)
downloadguile-4d6a7ac6ad5ea51927aec92f85b8526340a73270.tar.gz
Remove GOOPS-internal @slot-ref and @slot-set!
* module/oop/goops.scm: Remove definitions of @slot-ref and @slot-set!. They are equivalent to struct-ref and struct-set!. (define-standard-accessor-method): Reimplement using syntax-case. (bound-check-get, standard-get, standard-set): Replace @slot-ref and @slot-set! uses with struct-ref and struct-set!. * module/language/cps/reify-primitives.scm (primitive-module): Remove @slot-set! and @slot-ref references.
-rw-r--r--module/language/cps/reify-primitives.scm2
-rw-r--r--module/oop/goops.scm56
2 files changed, 21 insertions, 37 deletions
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 68de29494..501c23c94 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -69,7 +69,7 @@
bytevector-ieee-double-ref bytevector-ieee-double-set!
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
'(rnrs bytevectors))
- ((class-of @slot-ref @slot-set!) '(oop goops))
+ ((class-of) '(oop goops))
(else '(guile))))
(define (primitive-ref name k src)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index eb2b67cf0..1b86399b3 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -140,13 +140,7 @@
(eval-when (eval load compile)
(use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
- (add-interesting-primitive! 'class-of)
- (define (@slot-ref o n)
- (struct-ref o n))
- (define (@slot-set! o n v)
- (struct-set! o n v))
- (add-interesting-primitive! '@slot-ref)
- (add-interesting-primitive! '@slot-set!))
+ (add-interesting-primitive! 'class-of))
;; Then load the rest of GOOPS
(use-modules (oop goops util)
@@ -1193,44 +1187,34 @@
(define (make-generic-bound-check-getter proc)
(lambda (o) (assert-bound (proc o) o)))
-;; the idea is to compile the index into the procedure, for fastest
-;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
-
-(eval-when (eval load compile)
- (define num-standard-pre-cache 20))
-
-(define-macro (define-standard-accessor-method form . body)
- (let ((name (caar form))
- (n-var (cadar form))
- (args (cdr form)))
- (define (make-one x)
- (define (body-trans form)
- (cond ((not (pair? form)) form)
- ((eq? (car form) '@slot-ref)
- `(,(car form) ,(cadr form) ,x))
- ((eq? (car form) '@slot-set!)
- `(,(car form) ,(cadr form) ,x ,(cadddr form)))
- (else
- (map body-trans form))))
- `(lambda ,args ,@(map body-trans body)))
- `(define ,name
- (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache)))))
- (lambda (n)
- (if (< n ,num-standard-pre-cache)
- (vector-ref cache n)
- ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
+;;; Pre-generate getters and setters for the first 20 slots.
+(define-syntax define-standard-accessor-method
+ (lambda (stx)
+ (define num-standard-pre-cache 20)
+ (syntax-case stx ()
+ ((_ ((proc n) arg ...) body)
+ #`(define proc
+ (let ((cache (vector #,@(map (lambda (n*)
+ #`(lambda (arg ...)
+ (let ((n #,n*))
+ body)))
+ (iota num-standard-pre-cache)))))
+ (lambda (n)
+ (if (< n #,num-standard-pre-cache)
+ (vector-ref cache n)
+ (lambda (arg ...) body)))))))))
(define-standard-accessor-method ((bound-check-get n) o)
- (let ((x (@slot-ref o n)))
+ (let ((x (struct-ref o n)))
(if (unbound? x)
(slot-unbound o)
x)))
(define-standard-accessor-method ((standard-get n) o)
- (@slot-ref o n))
+ (struct-ref o n))
(define-standard-accessor-method ((standard-set n) o v)
- (@slot-set! o n v))
+ (struct-set! o n v))
;;; compute-getters-n-setters
;;;