1;;; atype.el --- atype functions -*- lexical-binding: t -*- 2 3;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. 4 5;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> 6;; Version: $Id$ 7;; Keywords: atype 8 9;; This file is part of APEL (A Portable Emacs Library). 10 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. 15 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. 20 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. 25 26;;; Code: 27 28(require 'alist) 29 30 31;;; @ field unifier 32;;; 33 34(defun field-unifier-for-default (a b) 35 (let ((ret 36 (cond ((equal a b) a) 37 ((null (cdr b)) a) 38 ((null (cdr a)) b) 39 ))) 40 (if ret 41 (list nil ret nil) 42 ))) 43 44(defun field-unify (a b) 45 (let ((f 46 (let ((type (car a))) 47 (and (symbolp type) 48 (intern (concat "field-unifier-for-" (symbol-name type))) 49 )))) 50 (or (fboundp f) 51 (setq f (function field-unifier-for-default)) 52 ) 53 (funcall f a b) 54 )) 55 56 57;;; @ type unifier 58;;; 59 60(defun assoc-unify (class instance) 61 (catch 'tag 62 (let ((cla (copy-alist class)) 63 (ins (copy-alist instance)) 64 (r class) 65 cell aret ret prev rest) 66 (while r 67 (setq cell (car r)) 68 (setq aret (assoc (car cell) ins)) 69 (if aret 70 (if (setq ret (field-unify cell aret)) 71 (progn 72 (if (car ret) 73 (setq prev (put-alist (car (car ret)) 74 (cdr (car ret)) 75 prev)) 76 ) 77 (if (nth 2 ret) 78 (setq rest (put-alist (car (nth 2 ret)) 79 (cdr (nth 2 ret)) 80 rest)) 81 ) 82 (setq cla (put-alist (car cell)(cdr (nth 1 ret)) cla)) 83 (setq ins (del-alist (car cell) ins)) 84 ) 85 (throw 'tag nil) 86 )) 87 (setq r (cdr r)) 88 ) 89 (setq r (copy-alist ins)) 90 (while r 91 (setq cell (car r)) 92 (setq aret (assoc (car cell) cla)) 93 (if aret 94 (if (setq ret (field-unify cell aret)) 95 (progn 96 (if (car ret) 97 (setq prev (put-alist (car (car ret)) 98 (cdr (car ret)) 99 prev)) 100 ) 101 (if (nth 2 ret) 102 (setq rest (put-alist (car (nth 2 ret)) 103 (cdr (nth 2 ret)) 104 rest)) 105 ) 106 (setq cla (del-alist (car cell) cla)) 107 (setq ins (put-alist (car cell)(cdr (nth 1 ret)) ins)) 108 ) 109 (throw 'tag nil) 110 )) 111 (setq r (cdr r)) 112 ) 113 (list prev (append cla ins) rest) 114 ))) 115 116(defun get-unified-alist (db al) 117 (let ((r db) ret) 118 (catch 'tag 119 (while r 120 (if (setq ret (nth 1 (assoc-unify (car r) al))) 121 (throw 'tag ret) 122 ) 123 (setq r (cdr r)) 124 )))) 125 126 127;;; @ utilities 128;;; 129 130(defun delete-atype (atl al) 131 (let* ((r atl) oal) 132 (setq oal 133 (catch 'tag 134 (while r 135 (if (nth 1 (assoc-unify (car r) al)) 136 (throw 'tag (car r)) 137 ) 138 (setq r (cdr r)) 139 ))) 140 (delete oal atl) 141 )) 142 143(defun remove-atype (sym al) 144 (and (boundp sym) 145 (set sym (delete-atype (eval sym) al)) 146 )) 147 148(defun replace-atype (atl old-al new-al) 149 (let ((r atl)) 150 (if (catch 'tag 151 (while r 152 (if (nth 1 (assoc-unify (car r) old-al)) 153 (throw 'tag (rplaca r new-al)) 154 ) 155 (setq r (cdr r)) 156 )) 157 atl))) 158 159(defun set-atype (sym al &rest options) 160 (if (null (boundp sym)) 161 (set sym al) 162 (let* ((replacement (memq 'replacement options)) 163 (ignore-fields (car (cdr (memq 'ignore options)))) 164 (remove (or (car (cdr (memq 'remove options))) 165 (let ((ral (copy-alist al))) 166 (mapc (lambda (type) 167 (setq ral (del-alist type ral))) 168 ignore-fields) 169 ral))) 170 ) 171 (set sym 172 (or (if replacement 173 (replace-atype (eval sym) remove al) 174 ) 175 (cons al 176 (delete-atype (eval sym) remove) 177 ) 178 ))))) 179 180 181;;; @ end 182;;; 183 184(require 'product) 185(product-provide (provide 'atype) (require 'apel-ver)) 186 187;;; atype.el ends here 188