--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/apel/atype.el	Mon Aug 13 09:39:39 2007 +0200
@@ -0,0 +1,189 @@
+;;; atype.el --- atype functions
+
+;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Version: $Id: atype.el,v 1.1 1997/06/03 04:18:34 steve Exp $
+;; Keywords: atype
+
+;; This file is part of APEL (A Portable Emacs Library).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'emu)
+(require 'alist)
+
+
+;;; @ 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 ((f
+	 (let ((type (car a)))
+	   (and (symbolp type)
+		(intern (concat "field-unifier-for-" (symbol-name type)))
+		))))
+    (or (fboundp f)
+	(setq f (function field-unifier-for-default))
+	)
+    (funcall f 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 (assoc (car cell) ins))
+	(if aret
+	    (if (setq ret (field-unify cell aret))
+		(progn
+		  (if (car ret)
+		      (setq prev (put-alist (car (car ret))
+					    (cdr (car ret))
+					    prev))
+		    )
+		  (if (nth 2 ret)
+		      (setq rest (put-alist (car (nth 2 ret))
+					    (cdr (nth 2 ret))
+					    rest))
+		    )
+		  (setq cla (put-alist (car cell)(cdr (nth 1 ret)) cla))
+		  (setq ins (del-alist (car cell) ins))
+		  )
+	      (throw 'tag nil)
+	      ))
+	(setq r (cdr r))
+	)
+      (setq r (copy-alist ins))
+      (while r
+	(setq cell (car r))
+	(setq aret (assoc (car cell) cla))
+	(if aret
+	    (if (setq ret (field-unify cell aret))
+		(progn
+		  (if (car ret)
+		      (setq prev (put-alist (car (car ret))
+					    (cdr (car ret))
+					    prev))
+		    )
+		  (if (nth 2 ret)
+		      (setq rest (put-alist (car (nth 2 ret))
+					    (cdr (nth 2 ret))
+					    rest))
+		    )
+		  (setq cla (del-alist (car cell) cla))
+		  (setq ins (put-alist (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))
+	))))
+
+
+;;; @ utilities
+;;;
+
+(defun delete-atype (atl al)
+  (let* ((r atl) ret oal)
+    (setq oal
+	  (catch 'tag
+	    (while r
+	      (if (setq ret (nth 1 (assoc-unify (car r) al)))
+		  (throw 'tag (car r))
+		)
+	      (setq r (cdr r))
+	      )))
+    (delete oal atl)
+    ))
+
+(defun remove-atype (sym al)
+  (and (boundp sym)
+       (set sym (delete-atype (eval sym) al))
+       ))
+
+(defun replace-atype (atl old-al new-al)
+  (let* ((r atl) ret oal)
+    (if (catch 'tag
+	  (while r
+	    (if (setq ret (nth 1 (assoc-unify (car r) old-al)))
+		(throw 'tag (rplaca r new-al))
+	      )
+	    (setq r (cdr r))
+	    ))
+	atl)))
+
+(defun set-atype (sym al &rest options)
+  (if (null (boundp sym))
+      (set sym al)
+    (let* ((replacement (memq 'replacement options))
+	   (ignore-fields (car (cdr (memq 'ignore options))))
+	   (remove (or (car (cdr (memq 'remove options)))
+		       (let ((ral (copy-alist al)))
+			 (mapcar (function
+				  (lambda (type)
+				    (setq ral (del-alist type ral))
+				    ))
+				 ignore-fields)
+			 ral)))
+	   )
+      (set sym
+	   (or (if replacement
+		   (replace-atype (eval sym) remove al)
+		 )
+	       (cons al
+		     (delete-atype (eval sym) remove)
+		     )
+	       )))))
+
+
+;;; @ end
+;;;
+
+(provide 'atype)
+
+;;; atype.el ends here