;;; atype.el --- atype functions;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>;; Version: $Id$;; 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;;;(defunfield-unifier-for-default(ab)(let((ret(cond((equalab)a)((null(cdrb))a)((null(cdra))b))))(ifret(listnilretnil))))(defunfield-unify(ab)(let((f(let((type(cara)))(and(symbolptype)(intern(concat"field-unifier-for-"(symbol-nametype)))))))(or(fboundpf)(setqf(functionfield-unifier-for-default)))(funcallfab)));;; @ type unifier;;;(defunassoc-unify(classinstance)(catch'tag(let((cla(copy-alistclass))(ins(copy-alistinstance))(rclass)cellaretretprevrest)(whiler(setqcell(carr))(setqaret(assoc(carcell)ins))(ifaret(if(setqret(field-unifycellaret))(progn(if(carret)(setqprev(put-alist(car(carret))(cdr(carret))prev)))(if(nth2ret)(setqrest(put-alist(car(nth2ret))(cdr(nth2ret))rest)))(setqcla(put-alist(carcell)(cdr(nth1ret))cla))(setqins(del-alist(carcell)ins)))(throw'tagnil)))(setqr(cdrr)))(setqr(copy-alistins))(whiler(setqcell(carr))(setqaret(assoc(carcell)cla))(ifaret(if(setqret(field-unifycellaret))(progn(if(carret)(setqprev(put-alist(car(carret))(cdr(carret))prev)))(if(nth2ret)(setqrest(put-alist(car(nth2ret))(cdr(nth2ret))rest)))(setqcla(del-alist(carcell)cla))(setqins(put-alist(carcell)(cdr(nth1ret))ins)))(throw'tagnil)))(setqr(cdrr)))(listprev(appendclains)rest))))(defunget-unified-alist(dbal)(let((rdb)ret)(catch'tag(whiler(if(setqret(nth1(assoc-unify(carr)al)))(throw'tagret))(setqr(cdrr))))));;; @ utilities;;;(defundelete-atype(atlal)(let*((ratl)retoal)(setqoal(catch'tag(whiler(if(setqret(nth1(assoc-unify(carr)al)))(throw'tag(carr)))(setqr(cdrr)))))(deleteoalatl)))(defunremove-atype(symal)(and(boundpsym)(setsym(delete-atype(evalsym)al))))(defunreplace-atype(atlold-alnew-al)(let*((ratl)retoal)(if(catch'tag(whiler(if(setqret(nth1(assoc-unify(carr)old-al)))(throw'tag(rplacarnew-al)))(setqr(cdrr))))atl)))(defunset-atype(symal&restoptions)(if(null(boundpsym))(setsymal)(let*((replacement(memq'replacementoptions))(ignore-fields(car(cdr(memq'ignoreoptions))))(remove(or(car(cdr(memq'removeoptions)))(let((ral(copy-alistal)))(mapcar(function(lambda(type)(setqral(del-alisttyperal))))ignore-fields)ral))))(setsym(or(ifreplacement(replace-atype(evalsym)removeal))(consal(delete-atype(evalsym)remove)))))));;; @ end;;;(provide'atype);;; atype.el ends here