Gauche:スロットアクセスの記述の短縮

Gauche:スロットアクセスの記述の短縮

スロットアクセスの記述の短縮

(use gauche.time)

;; with-slot-accessors
;;  binds variables to slot-accessors.
;;  (with-slot-accessors (binding ...) instance body ...)
;;   where binding is var or (var slot-name) .
(define-syntax with-slot-accessors
  (syntax-rules ()
    [(_ (binding ...) instance body ...)
     (%with-slot-accessors () (binding ...) instance body ...)]))

(define-syntax %with-slot-accessors
  (syntax-rules ()
    [(_ (new-binding ...) () instance body ...)
     (let (new-binding ...) body ...)]
    [(_ (new-binding ...) ((var slot-name) rest ...) instance body ...)
     (%with-slot-accessors
      (new-binding ... (var (getter-with-setter
                             (lambda ()  (slot-ref  instance 'slot-name))
                             (lambda (v) (slot-set! instance 'slot-name v)))))
      (rest ...) instance body ...)]
    [(_ (new-binding ...) (var rest ...) instance body ...)
     (%with-slot-accessors
      (new-binding ... (var (getter-with-setter
                             (lambda ()  (slot-ref  instance 'var))
                             (lambda (v) (slot-set! instance 'var v)))))
      (rest ...) instance body ...)]))


;; ***** examples *****

(define-class <3d-point> () (x y z))

(define p1 (make <3d-point>))
(define p2 (make <3d-point>))

(with-slot-accessors (x y z) p1
  (with-slot-accessors ([x2 x] [y2 y] [z2 z]) p2
    (set! (x)  10)
    (set! (y)  20)
    (set! (z)  30)
    (set! (x2) 100)
    (set! (y2) 200)
    (set! (z2) 300)))

(with-slot-accessors (x y z) p1
  (with-slot-accessors ([x2 x] [y2 y] [z2 z]) p2
    (format #t "p1=(~d ~d ~d)~%" (x)  (y)  (z))
    (format #t "p2=(~d ~d ~d)~%" (x2) (y2) (z2))))


;; ***** measure time *****

(define-syntax print-time
  (syntax-rules ()
    ((_ msg n body ...)
     (print msg (time-this n (lambda () body ...))))))

(define n 1000000)

(print)
(print-time   "slot-ref   : " n (list (slot-ref p1 'x) (slot-ref p1 'y) (slot-ref p1 'z)))
(print-time   "ref        : " n (list (ref p1 'x) (ref p1 'y) (ref p1 'z)))
(print-time   "~          : " n (list (~ p1 'x) (~ p1 'y) (~ p1 'z)))
(with-slot-accessors (x y z) p1 
  (print-time "this-1     : " n (list (x) (y) (z))))
(print-time   "this-2     : " n (with-slot-accessors (x y z) p1
                                  (list (x) (y) (z))))

(print)
(print-time   "slot-set!  : " n (slot-set! p1 'x 1000)
                                (slot-set! p1 'y 2000)
                                (slot-set! p1 'z 3000))
(print-time   "set! ref   : " n (set! (ref p1 'x) 1000)
                                (set! (ref p1 'y) 2000)
                                (set! (ref p1 'z) 3000))
(print-time   "set! ~     : " n (set! (~ p1 'x) 1000)
                                (set! (~ p1 'y) 2000)
                                (set! (~ p1 'z) 3000))
(with-slot-accessors (x y z) p1
  (print-time "set! this-1: " n (set! (x) 1000)
                                (set! (y) 2000)
                                (set! (z) 3000)))
(print-time   "set! this-2: " n (with-slot-accessors (x y z) p1
                                  (set! (x) 1000)
                                  (set! (y) 2000)
                                  (set! (z) 3000)))

p1=(10 20 30)
p2=(100 200 300)

slot-ref   : #<time-result 1000000 times/  0.348 real/  0.297 user/  0.047 sys>
ref        : #<time-result 1000000 times/  0.984 real/  1.063 user/  0.062 sys>
~          : #<time-result 1000000 times/  1.209 real/  1.297 user/  0.047 sys>
this-1     : #<time-result 1000000 times/  0.391 real/  0.391 user/  0.047 sys>
this-2     : #<time-result 1000000 times/  0.891 real/  1.108 user/  0.141 sys>

slot-set!  : #<time-result 1000000 times/  0.203 real/  0.203 user/  0.000 sys>
set! ref   : #<time-result 1000000 times/  0.844 real/  0.860 user/  0.031 sys>
set! ~     : #<time-result 1000000 times/  1.078 real/  1.141 user/  0.032 sys>
set! this-1: #<time-result 1000000 times/  0.309 real/  0.312 user/  0.000 sys>
set! this-2: #<time-result 1000000 times/  0.822 real/  1.078 user/  0.156 sys>

hamayama(2020/08/04 08:25:45 UTC)(2020/08/06 01:57:03 UTC)

Shiro(2020/08/05 03:25:57 UTC): 速いのはいいですね。Common Lispにwith-slotsがありますが、 identifier macroがあれば実装できるんだよな…

More ...