dummy objects in scheme

#lang racket
(require racket/match)

;;; common utilites
(define (assert-equal? a b)
  (or (equal? a b)
      (error (format "assert: ~a not equal to ~b" a b))))

;;; hash utilites
(define (list->hash lst)
  (define (f lst h)
    (if (null? lst) h
        (begin
          (hash-set! h (caar lst) (cdar lst))
          (f (cdr lst) h))))
  (f lst (make-hash)))

(define (element? x lst)
  (cond ((null? lst) #f)
        ((eq? (car x) (caar lst)) #t)
        (#t (element? x (cdr lst)))))

(define (union-pairs a b)
  (cond ((null? b) a)
        ((element? (car b) a)
         (union-pairs a (cdr b)))
        (#t (union-pairs (cons (car b) a) (cdr b)))))

(define (join-hash master-hash slave-hash)
  (if (not master-hash) slave-hash
      (list->hash (union-pairs (hash->list slave-hash) (hash->list master-hash)))))

;;; object utilites
(define Object #f)

(define (getf object field)
  (object (list 'get field)))

(define (setf object field newvalue)
  (object (list 'set field newvalue)))

(define (incf object field value)
  (setf object field (+ value (getf object field))))

(define (call object method-name . args)
  (let ((f (getf object method-name)))
    (apply f object args)))

(define (object->hash object)
  (if (and object (procedure? object))
      (object 'get-fields-hash)
      #f))

(define (make-object parent . args)
  (let* ((fields (join-hash (object->hash parent) (list->hash args))))
    (hash-set! fields '*parent* parent)
    (define (object event)
      (match event
        [(list 'get field) (hash-ref fields field)]
        [(list 'set field value) (hash-set! fields field value)]
        [get-fields-hash fields]))
    (and (hash-has-key? fields '*init*)
         ((hash-ref fields '*init*) object))
    object))

;;; object test
(let* ((a (make-object Object
            `(*init* . ,(lambda (self)
                          (display "init A\n")))
            '(fielda . 0)
            '(fieldb . b)
            `(methodc . ,(lambda (self x) (+ (getf self 'fielda) x)))))
       (b (make-object a
            `(*init* . ,(lambda (self)
                          (call (getf self '*parent*) '*init*)
                          (display "init B\n")))
            `(fielda . 1))))
  (assert-equal? 0  (getf a 'fielda))
  (assert-equal? 'b (getf a 'fieldb))
  (assert-equal? 1  (call a 'methodc +1))
  (assert-equal? 1  (getf b 'fielda))
  (assert-equal? 'b (getf b 'fieldb))
  (assert-equal? 2  (call b 'methodc +1))
  (assert-equal? 0  (getf (getf b '*parent*) 'fielda)))