1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00

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.
This commit is contained in:
Andy Wingo 2013-11-30 16:40:17 +01:00
parent 23e2e78067
commit 4d6a7ac6ad
2 changed files with 21 additions and 37 deletions

View file

@ -69,7 +69,7 @@
bytevector-ieee-double-ref bytevector-ieee-double-set! bytevector-ieee-double-ref bytevector-ieee-double-set!
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
'(rnrs bytevectors)) '(rnrs bytevectors))
((class-of @slot-ref @slot-set!) '(oop goops)) ((class-of) '(oop goops))
(else '(guile)))) (else '(guile))))
(define (primitive-ref name k src) (define (primitive-ref name k src)

View file

@ -140,13 +140,7 @@
(eval-when (eval load compile) (eval-when (eval load compile)
(use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
(add-interesting-primitive! 'class-of) (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!))
;; Then load the rest of GOOPS ;; Then load the rest of GOOPS
(use-modules (oop goops util) (use-modules (oop goops util)
@ -1193,44 +1187,34 @@
(define (make-generic-bound-check-getter proc) (define (make-generic-bound-check-getter proc)
(lambda (o) (assert-bound (proc o) o))) (lambda (o) (assert-bound (proc o) o)))
;; the idea is to compile the index into the procedure, for fastest ;;; Pre-generate getters and setters for the first 20 slots.
;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. (define-syntax define-standard-accessor-method
(lambda (stx)
(eval-when (eval load compile) (define num-standard-pre-cache 20)
(define num-standard-pre-cache 20)) (syntax-case stx ()
((_ ((proc n) arg ...) body)
(define-macro (define-standard-accessor-method form . body) #`(define proc
(let ((name (caar form)) (let ((cache (vector #,@(map (lambda (n*)
(n-var (cadar form)) #`(lambda (arg ...)
(args (cdr form))) (let ((n #,n*))
(define (make-one x) body)))
(define (body-trans form) (iota num-standard-pre-cache)))))
(cond ((not (pair? form)) form) (lambda (n)
((eq? (car form) '@slot-ref) (if (< n #,num-standard-pre-cache)
`(,(car form) ,(cadr form) ,x)) (vector-ref cache n)
((eq? (car form) '@slot-set!) (lambda (arg ...) body)))))))))
`(,(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)))))))
(define-standard-accessor-method ((bound-check-get n) o) (define-standard-accessor-method ((bound-check-get n) o)
(let ((x (@slot-ref o n))) (let ((x (struct-ref o n)))
(if (unbound? x) (if (unbound? x)
(slot-unbound o) (slot-unbound o)
x))) x)))
(define-standard-accessor-method ((standard-get n) o) (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) (define-standard-accessor-method ((standard-set n) o v)
(@slot-set! o n v)) (struct-set! o n v))
;;; compute-getters-n-setters ;;; compute-getters-n-setters
;;; ;;;