#lang scheme/base

;(require (planet "evector.scm" ("soegaard" "evector.plt" 1)))
(require (for-syntax scheme/base))
(provide (all-defined-out))

;; empty-bit-field : bit-field
(define empty-bit-field 0)

;; empty-bit-field? : bit-field -> boolean
(define empty-bit-field? zero?)

;; bit-field : bit-flag ... -> bit-field
(define (bit-field . flags)
  (if (null? flags) 0 (apply bitwise-ior flags)))

;; make-bit-field : (cons bit-flag boolean) ... -> bit-field
(define (make-bit-field . pairs)
  (apply bit-field (map (lambda (pair)
                          (if (cdr pair) (car pair) 0))
                        pairs)))

(define-syntax (define-bit-flags stx)
  (syntax-case stx ()
    [(_ (x1 x2 ...))
     (with-syntax ([(i1 i2 ...) (for/list ([i (in-range (length (syntax->list #'(x1 x2 ...))))])
                                  (expt 2 i))])
       #'(begin (define x1 i1)
                (define x2 i2)
                ...))]))

;; bit-flag-set? : bit-field bit-flag -> boolean
(define (bit-flag-set? bf flag)
  (not (zero? (bitwise-and bf flag))))

(define-struct attributed ([value #:mutable] attributes) #:transparent)

(define-syntax (object-table stx)
  (syntax-case stx ()
    [(_ [key . value-info] ...)
     (with-syntax ([(name ...)
                    (map (lambda (stx)
                           (let ([x (syntax->datum stx)])
                             (if (string? x) x (symbol->string x))))
                         (syntax->list #'(key ...)))]
                   [(value ...)
                    (map (lambda (stx)
                           (syntax-case stx ()
                             [(value) #'value]
                             [(value (attributes ...))
                              #'(make-attributed value (bit-field attributes ...))]
                             [(getter setter (attributes ...))
                              #'(make-attributed (make-ref getter setter (lambda () 'false))
                                                 (bit-field DONT-DELETE? attributes ...))]))
                         (syntax->list #'(value-info ...)))])
       #'(let ([table (make-hash)])
           (for ([n (list name ...)]
                 [v (list value ...)])
             (hash-set! table n v))
           table))]))
;       #'(hash-table 'equal property ...))]))

;; CONVENTION: Never allow a closure to close over a binding to an object's
;;             property table; this may prevent garbage collection of an object's
;;             properties if its table is replaced...?
(define-struct object ([call #:mutable] [construct #:mutable] proto class [properties #:mutable]) #:transparent)
(define-struct (array object) (vector) #:transparent)
(define-struct ref (get set! delete!))

(define (function? x)
  (and (object? x)
       (object-call x)
       #t))

(define-bit-flags (READ-ONLY? DONT-ENUM? DONT-DELETE?))