1 ;;; atype.el --- atype functions
3 ;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Version: $Id: atype.el,v 6.6 1997/03/10 14:11:23 morioka Exp $
9 ;; This file is part of APEL (A Portable Emacs Library).
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 2, or (at
14 ;; your option) any later version.
16 ;; This program is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
28 (require 'emu) ; for backward compatibility.
29 (require 'poe) ; delete.
36 (defun field-unifier-for-default (a b)
46 (defun field-unify (a b)
50 (intern (concat "field-unifier-for-" (symbol-name type)))
53 (setq f (function field-unifier-for-default))
62 (defun assoc-unify (class instance)
64 (let ((cla (copy-alist class))
65 (ins (copy-alist instance))
67 cell aret ret prev rest)
70 (setq aret (assoc (car cell) ins))
72 (if (setq ret (field-unify cell aret))
75 (setq prev (put-alist (car (car ret))
80 (setq rest (put-alist (car (nth 2 ret))
84 (setq cla (put-alist (car cell)(cdr (nth 1 ret)) cla))
85 (setq ins (del-alist (car cell) ins))
91 (setq r (copy-alist ins))
94 (setq aret (assoc (car cell) cla))
96 (if (setq ret (field-unify cell aret))
99 (setq prev (put-alist (car (car ret))
104 (setq rest (put-alist (car (nth 2 ret))
108 (setq cla (del-alist (car cell) cla))
109 (setq ins (put-alist (car cell)(cdr (nth 1 ret)) ins))
115 (list prev (append cla ins) rest)
118 (defun get-unified-alist (db al)
122 (if (setq ret (nth 1 (assoc-unify (car r) al)))
132 (defun delete-atype (atl al)
133 (let* ((r atl) ret oal)
137 (if (setq ret (nth 1 (assoc-unify (car r) al)))
145 (defun remove-atype (sym al)
147 (set sym (delete-atype (eval sym) al))
150 (defun replace-atype (atl old-al new-al)
151 (let* ((r atl) ret oal)
154 (if (setq ret (nth 1 (assoc-unify (car r) old-al)))
155 (throw 'tag (rplaca r new-al))
161 (defun set-atype (sym al &rest options)
162 (if (null (boundp sym))
164 (let* ((replacement (memq 'replacement options))
165 (ignore-fields (car (cdr (memq 'ignore options))))
166 (remove (or (car (cdr (memq 'remove options)))
167 (let ((ral (copy-alist al)))
170 (setq ral (del-alist type ral))
177 (replace-atype (eval sym) remove al)
180 (delete-atype (eval sym) remove)
189 (product-provide (provide 'atype) (require 'apel-ver))
191 ;;; atype.el ends here