mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-30 06:50:31 +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:
parent
23e2e78067
commit
4d6a7ac6ad
2 changed files with 21 additions and 37 deletions
|
@ -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)
|
||||||
|
|
|
@ -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)
|
|
||||||
((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)
|
(lambda (n)
|
||||||
(if (< n ,num-standard-pre-cache)
|
(if (< n #,num-standard-pre-cache)
|
||||||
(vector-ref cache n)
|
(vector-ref cache n)
|
||||||
((lambda (,n-var) (lambda ,args ,@body)) n)))))))
|
(lambda (arg ...) body)))))))))
|
||||||
|
|
||||||
(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
|
||||||
;;;
|
;;;
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue