2 ;;; $Id: tl-list.el,v 2.5 1994/12/27 01:49:41 morioka Exp $
14 "Returns the last element in the list <LIST>.
15 [mol's Common Lisp emulating function]"
16 (nthcdr (- (length list) 1) list)
19 (defun butlast (x &optional n)
20 "Returns a copy of LIST with the last N elements removed.
21 [tl-list.el: imported from cl.el]"
22 (if (and n (<= n 0)) x
23 (nbutlast (copy-sequence x) n)))
25 (defun nbutlast (x &optional n)
26 "Modifies LIST to remove the last N elements.
27 [tl-list.el: imported from cl.el]"
32 (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
36 (defun nth-prev (n ls)
37 "Return elements of LS until N - 1 th. [tl-list.el]"
38 (butlast ls (- (length ls) n))
41 (defun except-nth (n ls)
42 "Return elements of LS except N th. [tl-list.el]"
43 (append (nth-prev n ls) (nthcdr (+ 1 n) ls))
46 (defun last-element (ls)
47 "Return last element. [tl-list.el]"
54 (fset 'is-member 'member)
60 (defun put-alist (item value alist)
61 "If there is a pair whose car is <ITEM>, replace its cdr by <VALUE>.
62 If there is not such pair, create new pair (<ITEM> . <VALUE>) and
63 return new alist whose car is the new pair and cdr is <ALIST>.
64 [mol's ELIS emulating function]"
65 (if (assoc item alist)
67 (rplacd (assoc item alist) value)
69 (cons (cons item value) alist)
72 (defun del-alist (item alist)
73 "If there is a pair whose key is <ITEM>, delete it from <ALIST>.
74 [mol's ELIS emulating function]"
75 (if (equal item (car (car alist)))
82 (if (equal item (car (car r)))
91 (defun set-alist (sym item value)
92 (if (not (boundp sym))
95 (set sym (put-alist item value (eval sym)))
102 (defun fetch-field (key alist)
106 (defun fetch-field-value (key alist)
107 (cdr (assoc key alist))
110 (fset 'put-field 'put-alist)
111 (fset 'delete-field 'del-alist)
113 (defun put-fields (tp c)
118 (if (not (if (setq ret (fetch-field (car f) c))
119 (equal (cdr ret)(cdr f))
131 (defun field-unifier-for-default (a b)
133 (cond ((equal a b) a)
141 (defun field-unify (a b)
142 (let ((sym (symbol-concat "field-unifier-for-" (car a))))
143 (if (not (fboundp sym))
144 (setq sym (function field-unifier-for-default))
153 (defun assoc-unify (class instance)
155 (let ((cla (copy-alist class))
156 (ins (copy-alist instance))
158 cell aret ret prev rest)
161 (setq aret (fetch-field (car cell) ins))
163 (if (setq ret (field-unify cell aret))
166 (setq prev (put-field (car (car ret))
171 (setq rest (put-field (car (nth 2 ret))
175 (setq cla (put-field (car cell)(cdr (nth 1 ret)) cla))
176 (setq ins (delete-field (car cell) ins))
182 (setq r (copy-alist ins))
185 (setq aret (fetch-field (car cell) cla))
187 (if (setq ret (field-unify cell aret))
190 (setq prev (put-field (car (car ret))
195 (setq rest (put-field (car (nth 2 ret))
199 (setq cla (delete-field (car cell) cla))
200 (setq ins (put-field (car cell)(cdr (nth 1 ret)) ins))
206 (list prev (append cla ins) rest)
209 (defun get-unified-alist (db al)
213 (if (setq ret (nth 1 (assoc-unify (car r) al)))
219 (defun set-atype (sym al)
220 (if (null (boundp sym))
222 (let ((ret (get-unified-alist (eval sym) al)))
223 (if (not (equal ret al))
224 (set sym (cons al (eval sym)))