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., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
35 (defun field-unifier-for-default (a b)
45 (defun field-unify (a b)
49 (intern (concat "field-unifier-for-" (symbol-name type)))
52 (setq f (function field-unifier-for-default))
61 (defun assoc-unify (class instance)
63 (let ((cla (copy-alist class))
64 (ins (copy-alist instance))
66 cell aret ret prev rest)
69 (setq aret (assoc (car cell) ins))
71 (if (setq ret (field-unify cell aret))
74 (setq prev (put-alist (car (car ret))
79 (setq rest (put-alist (car (nth 2 ret))
83 (setq cla (put-alist (car cell)(cdr (nth 1 ret)) cla))
84 (setq ins (del-alist (car cell) ins))
90 (setq r (copy-alist ins))
93 (setq aret (assoc (car cell) cla))
95 (if (setq ret (field-unify cell aret))
98 (setq prev (put-alist (car (car ret))
103 (setq rest (put-alist (car (nth 2 ret))
107 (setq cla (del-alist (car cell) cla))
108 (setq ins (put-alist (car cell)(cdr (nth 1 ret)) ins))
114 (list prev (append cla ins) rest)
117 (defun get-unified-alist (db al)
121 (if (setq ret (nth 1 (assoc-unify (car r) al)))
131 (defun delete-atype (atl al)
132 (let* ((r atl) ret oal)
136 (if (setq ret (nth 1 (assoc-unify (car r) al)))
144 (defun remove-atype (sym al)
146 (set sym (delete-atype (eval sym) al))
149 (defun replace-atype (atl old-al new-al)
150 (let* ((r atl) ret oal)
153 (if (setq ret (nth 1 (assoc-unify (car r) old-al)))
154 (throw 'tag (rplaca r new-al))
160 (defun set-atype (sym al &rest options)
161 (if (null (boundp sym))
163 (let* ((replacement (memq 'replacement options))
164 (ignore-fields (car (cdr (memq 'ignore options))))
165 (remove (or (car (cdr (memq 'remove options)))
166 (let ((ral (copy-alist al)))
169 (setq ral (del-alist type ral))
176 (replace-atype (eval sym) remove al)
179 (delete-atype (eval sym) remove)
189 ;;; atype.el ends here