Delete garbages.

[elisp/tm.git] / tl-list.el

diff --git a/tl-list.el b/tl-list.el
deleted file mode 100644 (file)
index 4c2a538..0000000
--- a/tl-list.el
+++ /dev/null
@@ -1,225 +0,0 @@
-;;;
-;;; $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)
-  "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]"
-  (if (assoc item alist)
-      (progn
-       (rplacd (assoc item alist) value)
-       alist)
-    (cons (cons item value) alist)
-    ))
-
-(defun del-alist (item 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)
-    (let ((pr alist)
-         (r (cdr alist))
-         )
-      (catch 'tag
-       (while (not (null r))
-         (if (equal item (car (car r)))
-             (progn
-               (rplacd pr (cdr r))
-               (throw 'tag alist)))
-         (setq pr r)
-         (setq r (cdr r))
-         )
-       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)
-  )
-
-(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)))
-       ))))