diff options
author | Andy Wingo <wingo@pobox.com> | 2013-11-30 16:40:17 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-11-30 18:46:14 +0100 |
commit | 4d6a7ac6ad5ea51927aec92f85b8526340a73270 (patch) | |
tree | c864dca62467f9300738ec0e3ff654d6da4a15a4 | |
parent | 23e2e78067787da3dabfded1b3a3f7a10905b4a8 (diff) | |
download | guile-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.scm | 2 | ||||
-rw-r--r-- | module/oop/goops.scm | 56 |
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 ;;; |