+
+(defun put-fields (tp c)
+ (catch 'tag
+ (let ((r tp) f ret)
+ (while r
+ (setq f (car r))
+ (if (not (if (setq ret (fetch-field (car f) c))
+ (equal (cdr ret)(cdr f))
+ (setq c (cons f c))
+ ))
+ (throw 'tag 'error))
+ (setq r (cdr r))
+ ))
+ c))
+
+
+;;; @ field unifier
+;;;
+
+(defun field-unifier-for-default (a b)
+ (let ((ret
+ (cond ((equal a b) a)
+ ((null (cdr b)) a)
+ ((null (cdr a)) b)
+ )))
+ (if ret
+ (list nil ret nil)
+ )))
+
+(defun field-unify (a b)
+ (let ((sym (symbol-concat "field-unifier-for-" (car a))))
+ (if (not (fboundp sym))
+ (setq sym (function field-unifier-for-default))
+ )
+ (funcall sym a b)
+ ))
+
+
+;;; @ type unifier
+;;;
+
+(defun assoc-unify (class instance)
+ (catch 'tag
+ (let ((cla (copy-alist class))
+ (ins (copy-alist instance))
+ (r class)
+ cell aret ret prev rest)
+ (while r
+ (setq cell (car r))
+ (setq aret (fetch-field (car cell) ins))
+ (if aret
+ (if (setq ret (field-unify cell aret))
+ (progn
+ (if (car ret)
+ (setq prev (put-field (car (car ret))
+ (cdr (car ret))
+ prev))
+ )
+ (if (nth 2 ret)
+ (setq rest (put-field (car (nth 2 ret))
+ (cdr (nth 2 ret))
+ rest))
+ )
+ (setq cla (put-field (car cell)(cdr (nth 1 ret)) cla))
+ (setq ins (delete-field (car cell) ins))
+ )
+ (throw 'tag nil)
+ ))
+ (setq r (cdr r))
+ )
+ (setq r (copy-alist ins))
+ (while r
+ (setq cell (car r))
+ (setq aret (fetch-field (car cell) cla))
+ (if aret
+ (if (setq ret (field-unify cell aret))
+ (progn
+ (if (car ret)
+ (setq prev (put-field (car (car ret))
+ (cdr (car ret))
+ prev))
+ )
+ (if (nth 2 ret)
+ (setq rest (put-field (car (nth 2 ret))
+ (cdr (nth 2 ret))
+ rest))
+ )
+ (setq cla (delete-field (car cell) cla))
+ (setq ins (put-field (car cell)(cdr (nth 1 ret)) ins))
+ )
+ (throw 'tag nil)
+ ))
+ (setq r (cdr r))
+ )
+ (list prev (append cla ins) rest)
+ )))
+
+(defun get-unified-alist (db al)
+ (let ((r db) ret)
+ (catch 'tag
+ (while r
+ (if (setq ret (nth 1 (assoc-unify (car r) al)))
+ (throw 'tag ret)
+ )
+ (setq r (cdr r))
+ ))))
+
+(defun set-atype (sym al)
+ (if (null (boundp sym))
+ (set sym al)
+ (let ((ret (get-unified-alist (eval sym) al)))
+ (if (not (equal ret al))
+ (set sym (cons al (eval sym)))
+ ))))