オブジェクトシステム

(define *table* (make-eq-hashtable))

(define boot-object
  (lambda (object)
    (if (not (hashtable-contains? *table* object))
      (let ((proto (make-eq-hashtable)))
        (hashtable-set! proto '__proto__ #f)
        (hashtable-set! *table* object proto)))))

(define property-hashtable-ref
  (lambda (object)
    (boot-object object)
    (hashtable-ref *table* object 'not-found)))

(define property-get
  (lambda (object property)
    (hashtable-ref (property-hashtable-ref object) property 'not-found)))

(define property-set!
  (lambda (object property value)
    (hashtable-set! (property-hashtable-ref object) property value)))

(define ->
  (lambda (object property)
    (let ((value (property-get object property))
          (proto (property-get object '__proto__)))
      (if (and proto (eq? value 'not-found))
        (-> proto property)
        value))))


(define make-plain-object
  (lambda ()
    (let ((object (lambda () #f)))
      object)))

(define make-constructor
  (lambda (proc)
    (let ((constructor (lambda (this) (proc this) this))
          (prototype (make-plain-object)))
    (property-set! constructor 'prototype prototype)
    (property-set! prototype 'constructor constructor)
    constructor)))

(define allocate
  (lambda (constructor)
    (let ((object (make-plain-object)))
      (property-set! object '__proto__ (-> constructor 'prototype))
      object)))

(define new
  (lambda (constructor)
    (let ((this (allocate constructor)))
      (constructor this))))

(define instance-of?
  (lambda (object constructor)
    (or (eq? (-> object 'constructor) constructor)
      (let ((proto (-> object '__proto__)))
        (and proto (instance-of? proto constructor))))))

(define <object>
  (make-constructor values))

(define object (new <object>))
(property-set! object 'foo 123)

(define new-object (new <object>))
(property-set! new-object '__proto__ object)

(display (-> new-object 'foo)) ; 123
(newline)

(property-set! new-object 'foo 456)

(display (-> new-object 'foo)) ; 456
(newline)

(display (-> object 'foo)) ; 123
(newline)

いっぺんにプロパティを設定するために、properties-set!関数を作ろうと思ったけど、途中で飽きた。
下は、その時できた副産物。

(define-syntax define-hashtable
  (syntax-rules ()
    ((_ (key value) ...)
     (let ((hashtable (make-eq-hashtable)))
       (hashtable-set! hashtable key value) ...
       hashtable))))

こんな感じに使う。

(define h
  (define-hashtable
    ('foo 123)
    ('bar 345)
    ('baz 567)))

(display (hashtable-ref h 'foo #f)) ; => 123
(newline)