;;;
-;;; $Id: tl-list.el,v 0.3 1994/07/16 04:08:52 morioka Exp morioka $
+;;; $Id: tl-list.el,v 2.5 1994/12/27 01:49:41 morioka Exp $
;;;
(provide 'tl-list)
+(require 'tl-str)
+
+
+;;; @ list
+;;;
+
+(defun last (list)
+ "Returns the last element in the list <LIST>.
+[mol's Common Lisp emulating function]"
+ (nthcdr (- (length list) 1) list)
+ )
+
+(defun butlast (x &optional n)
+ "Returns a copy of LIST with the last N elements removed.
+[tl-list.el: imported from cl.el]"
+ (if (and n (<= n 0)) x
+ (nbutlast (copy-sequence x) n)))
+
+(defun nbutlast (x &optional n)
+ "Modifies LIST to remove the last N elements.
+[tl-list.el: imported from cl.el]"
+ (let ((m (length x)))
+ (or n (setq n 1))
+ (and (< n m)
+ (progn
+ (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
+ x))))
+
+
+(defun nth-prev (n ls)
+ "Return elements of LS until N - 1 th. [tl-list.el]"
+ (butlast ls (- (length ls) n))
+ )
+
+(defun except-nth (n ls)
+ "Return elements of LS except N th. [tl-list.el]"
+ (append (nth-prev n ls) (nthcdr (+ 1 n) ls))
+ )
+
+(defun last-element (ls)
+ "Return last element. [tl-list.el]"
+ (car (last ls))
+ )
+
+
+;;; @ set
+;;;
+(fset 'is-member 'member)
+
+
;;; @ alist
;;;
(defun put-alist (item value alist)
- "\t(put-alist <ITEM> <VALUE> <ALIST>)\n
-If there is a pair whose car is <ITEM>, replace its cdr by <VALUE>.
+ "If there is a pair whose car is <ITEM>, replace its cdr by <VALUE>.
If there is not such pair, create new pair (<ITEM> . <VALUE>) and
return new alist whose car is the new pair and cdr is <ALIST>.
[mol's ELIS emulating function]"
))
(defun del-alist (item alist)
- "\t(del-alist <ITEM> <ALIST>)\n
-If there is a pair whose key is <ITEM>, delete it from <ALIST>.
+ "If there is a pair whose key is <ITEM>, delete it from <ALIST>.
[mol's ELIS emulating function]"
(if (equal item (car (car alist)))
(cdr alist)
)
alist))))
+(defun set-alist (sym item value)
+ (if (not (boundp sym))
+ (set sym nil)
+ )
+ (set sym (put-alist item value (eval sym)))
+ )
+
;;; @ field
;;;
(defun fetch-field (key alist)
- (assoc key alist))
+ (assoc key alist)
+ )
+
+(defun fetch-field-value (key alist)
+ (cdr (assoc key alist))
+ )
(fset 'put-field 'put-alist)
(fset 'delete-field 'del-alist)
+
+(defun put-fields (tp c)
+ (catch 'tag
+ (let ((r tp) f ret)
+ (while r
+ (setq f (car r))
+ (if (not (if (setq ret (fetch-field (car f) c))
+ (equal (cdr ret)(cdr f))
+ (setq c (cons f c))
+ ))
+ (throw 'tag 'error))
+ (setq r (cdr r))
+ ))
+ c))
+
+
+;;; @ field unifier
+;;;
+
+(defun field-unifier-for-default (a b)
+ (let ((ret
+ (cond ((equal a b) a)
+ ((null (cdr b)) a)
+ ((null (cdr a)) b)
+ )))
+ (if ret
+ (list nil ret nil)
+ )))
+
+(defun field-unify (a b)
+ (let ((sym (symbol-concat "field-unifier-for-" (car a))))
+ (if (not (fboundp sym))
+ (setq sym (function field-unifier-for-default))
+ )
+ (funcall sym a b)
+ ))
+
+
+;;; @ type unifier
+;;;
+
+(defun assoc-unify (class instance)
+ (catch 'tag
+ (let ((cla (copy-alist class))
+ (ins (copy-alist instance))
+ (r class)
+ cell aret ret prev rest)
+ (while r
+ (setq cell (car r))
+ (setq aret (fetch-field (car cell) ins))
+ (if aret
+ (if (setq ret (field-unify cell aret))
+ (progn
+ (if (car ret)
+ (setq prev (put-field (car (car ret))
+ (cdr (car ret))
+ prev))
+ )
+ (if (nth 2 ret)
+ (setq rest (put-field (car (nth 2 ret))
+ (cdr (nth 2 ret))
+ rest))
+ )
+ (setq cla (put-field (car cell)(cdr (nth 1 ret)) cla))
+ (setq ins (delete-field (car cell) ins))
+ )
+ (throw 'tag nil)
+ ))
+ (setq r (cdr r))
+ )
+ (setq r (copy-alist ins))
+ (while r
+ (setq cell (car r))
+ (setq aret (fetch-field (car cell) cla))
+ (if aret
+ (if (setq ret (field-unify cell aret))
+ (progn
+ (if (car ret)
+ (setq prev (put-field (car (car ret))
+ (cdr (car ret))
+ prev))
+ )
+ (if (nth 2 ret)
+ (setq rest (put-field (car (nth 2 ret))
+ (cdr (nth 2 ret))
+ rest))
+ )
+ (setq cla (delete-field (car cell) cla))
+ (setq ins (put-field (car cell)(cdr (nth 1 ret)) ins))
+ )
+ (throw 'tag nil)
+ ))
+ (setq r (cdr r))
+ )
+ (list prev (append cla ins) rest)
+ )))
+
+(defun get-unified-alist (db al)
+ (let ((r db) ret)
+ (catch 'tag
+ (while r
+ (if (setq ret (nth 1 (assoc-unify (car r) al)))
+ (throw 'tag ret)
+ )
+ (setq r (cdr r))
+ ))))
+
+(defun set-atype (sym al)
+ (if (null (boundp sym))
+ (set sym al)
+ (let ((ret (get-unified-alist (eval sym) al)))
+ (if (not (equal ret al))
+ (set sym (cons al (eval sym)))
+ ))))
projects / elisp / tm.git / blobdiff