Toy implementation of classes using closures, Scheme

Language: Layout:

;guile 2.2.3

;Toy implementation of classes using closures.

(define-syntax class
  (syntax-rules ()
    [(_ cname (x e) ...)
     (define (cname . initargs)
     (let ((__attrs__ `((x . , e) ...))
	   (__cname__ (quote cname)))
       (let [(obj (lambda (slot . args)
	 (if (null? args)
	     (cdr (assoc slot __attrs__))
	     (begin (set! __attrs__
			  (_update __attrs__ slot (car args)))
		    (cdr (assoc slot __attrs__))))))]
	 (if (get obj __init__)
	     (apply (get obj __init__) (cons obj initargs)))
	 obj)))]))

(define-syntax get
  (syntax-rules ()
    [(_ obj attr) (obj (quote attr))]))
(define-syntax set
  (syntax-rules ()   
    [(_ obj attr val)(obj (quote attr) val)]))
(define-syntax call
  (syntax-rules ()
    [(_ obj f)((obj (quote f)) obj)]
    [(_ obj f arg ...)((obj (quote f)) obj arg ...)]))
(define *__fixed_obj__* #f)
(define-syntax with-fixed-obj
  (syntax-rules ()
    [(_ obj b ...)
     (let [(old *__fixed_obj__*)]
       (begin (set! *__fixed_obj__* obj)
	      (let [(res (begin b ...))]
	           (set! *__fixed_obj__* old) res)))]))
(define-syntax get/
  (syntax-rules ()
    [(_ slot)(get *__fixed_obj__* slot)]))
(define-syntax set/
  (syntax-rules () 
    [(_ slot val)(set *__fixed_obj__* slot val)]))
(define-syntax call/
  (syntax-rules ()
    [(_ f arg ...)(call *__fixed_obj__* f arg ...)]))

(define-syntax method
  (syntax-rules ()
    [(_ (arg ...) b ...)
     (lambda (self arg ...)
       (with-fixed-obj self b ...))]))

(define (_update H slot val)
  (cons (cons slot val) H))

;; example usage:
(define (print x)(display x)(newline))

(class Counter (__init__ (method (start) (set/ cnt (- start 1))))
               (count (method () (set/ cnt (+ 1 (get/ cnt)))))
               (increment (method (n) (set/ cnt (+ n (get/ cnt))))))

(define b (Counter 0)) ;counter starting from 0
(print (call b count)) ;calls method count. --> 0
(print (call b count)) ; --> 1
(print (get b cnt)) ;get the value of the attribute cnt (without incrementing it)
(print (call b increment 5)) ;calls method increment with argument 5. -->6

; an object can also be fixed:
(set b cnt -1) ;reset b
(print "---")
; this is equivalent:
(with-fixed-obj b
  (print (call/ count))
  (print (call/ count))
  (print (get/ cnt))
  (print (call/ increment 5)))

[ + ] Show input
Absolute running time: 0.23 sec, cpu time: 0.06 sec, memory peak: 9 Mb, absolute service time: 0,39 sec