;;;; type-extend-support.scm
;;;; Kon Lovett, Sep '09

(module type-extend-support

(;export
  typdef-type
  typdef-pred
  typdef-proc
  typdef-add!
  typdef-delete!
  typdef/object
  typdef/type)

(import scheme)

(import chicken)

(import srfi-18)
(require-library srfi-18)

(import lookup-table-synch)
(require-library lookup-table-synch)

;;

(define (make-typdef typ pred proc) (vector typ pred proc))
(define (typdef-type ti) (vector-ref ti 0))
(define (typdef-pred ti) (vector-ref ti 1))
(define (typdef-proc ti) (vector-ref ti 2))

;;

(define +typdefs+ (make-dict/synch eq? 0))

(define (typdef-add! typ pred proc) (dict-set!/synch +typdefs+ typ (make-typdef typ pred proc)))
(define (typdef-delete! typ) (dict-delete!/synch +typdefs+ typ))
(define (typdef/object obj) (dict-search/synch +typdefs+ (lambda (t ti) ((typdef-pred ti) obj))))
(define (typdef/type typ) (dict-ref/synch +typdefs+ typ))

) ;module type-extend-support