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