+++ /dev/null
-(defun concord-object-p (object)
- (eq (aref object 0) :concord))
-
-(defun concord-object-type (object)
- (and (concord-object-p object)
- (aref object 1)))
-
-(defun concord-object-id (object)
- (and (concord-object-p object)
- (aref object 2)))
-
-(defun concord-define-object (type spec &optional id)
- (concord-el-define-object type spec id))
-
-(defun concord-object-get-value (object feature)
- (concord-el-object-get-value object feature))
-
-(defun concord-object-spec (object)
- (concord-el-object-spec object))
-
-(defun concord-feature-list (type)
- (concord-el-feature-list type))
-
-(defun concord-map-objects (function type)
- (concord-el-map-objects function type))
-
-(defun concord-map-feature (function feature type)
- (concord-el-map-feature function feature type))
-
-
-(defvar concord-el-type-list-table
- (make-hash-table))
-
-(defun concord-el-get-type-table (type)
- (gethash type concord-el-type-list-table))
-
-(defun concord-el-get-type-table-create (type)
- (let ((type-table (gethash type concord-el-type-list-table)))
- (unless type-table
- (setq type-table (make-hash-table))
- (puthash type type-table concord-el-type-list-table))
- type-table))
-
-(defun concord-el-type-table-get-feature-table (type-table feature)
- (gethash feature type-table))
-
-(defun concord-el-type-table-get-feature-table-create (type-table feature)
- (let ((feature-table (gethash feature type-table)))
- (unless feature-table
- (setq feature-table (make-hash-table))
- (puthash feature feature-table type-table))
- feature-table))
-
-
-(defun concord-el-type-table-get-object-feature (type-table object-id feature)
- (let ((feature-table
- (concord-el-type-table-get-feature-table type-table feature)))
- (if feature-table
- (gethash object-id feature-table))))
-
-(defun concord-el-type-table-put-object-feature (type-table object-id
- feature value)
- (let ((feature-table
- (concord-el-type-table-get-feature-table-create type-table feature)))
- (cond
- ((eq '->subsumptive feature)
- (dolist (spec value)
- (concord-el-type-table-put-object type-table spec))))
- (puthash object-id value feature-table)))
-
-
-(defun concord-el-type-table-put-object (type-table spec &optional id)
- (let (self)
- (unless id
- (setq id (cdr (assq '=id spec))))
- (when id
- (dolist (feature spec)
- (concord-el-type-table-put-object-feature
- type-table id (car feature)(cdr feature)))
- (setq self (vector :concord type id))
- (concord-el-type-table-put-object-feature
- type-table id '=self self)
- self)))
-
-(defun concord-el-define-object (type spec &optional id)
- (let ((type-table (concord-el-get-type-table-create type)))
- (if type-table
- (concord-el-type-table-put-object type-table spec id))))
-
-(defun concord-el-object-get-value (object feature)
- (let ((type (concord-object-type object))
- type-table id)
- (when (and (setq type-table (concord-el-get-type-table type))
- (setq id (concord-object-id object)))
- (concord-el-type-table-get-object-feature type-table id feature))))
-
-(defun concord-el-object-spec (object)
- (let ((type (concord-object-type object))
- dest ret)
- (dolist (feature (concord-el-feature-list type))
- (when (setq ret (concord-el-object-get-value object feature))
- (setq dest (cons (cons feature ret) dest))))
- dest))
-
-(defun concord-el-map-feature (function feature type)
- (let ((type-table (concord-el-get-type-table type))
- feature-table self)
- (if type-table
- (if (setq feature-table
- (concord-el-type-table-get-feature-table
- type-table feature))
- (maphash (lambda (id val)
- (setq self
- (concord-el-type-table-get-object-feature
- type-table id '=self))
- (funcall function self val))
- feature-table)))))
-
-(defun concord-el-map-objects (function type)
- (let ((type-table (concord-el-get-type-table type))
- feature-table)
- (if type-table
- (if (setq feature-table
- (concord-el-type-table-get-feature-table
- type-table '=self))
- (maphash (lambda (id self)
- (funcall function self))
- feature-table)))))
-
-(defun concord-el-feature-list (type)
- (let (dest)
- (maphash (lambda (key val)
- (setq dest (cons key dest))
- nil)
- (concord-el-get-type-table type))
- dest))