tl-list.el

   1 ;;;
   2 ;;; $Id: tl-list.el,v 2.0 1994/11/08 11:14:20 morioka Exp $
   3 ;;;
   4
   5 (provide 'tl-list)
   6
   7 (require 'tl-str)
   8
   9
  10 ;;; @ list
  11 ;;;
  12
  13 (defun last (list)
  14   "Returns the last element in the list <LIST>.
  15 [mol's Common Lisp emulating function]"
  16   (nthcdr (- (length list) 1) list)
  17   )
  18
  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)))
  24
  25 (defun nbutlast (x &optional n)
  26   "Modifies LIST to remove the last N elements.
  27 [tl-list.el: imported from cl.el]"
  28   (let ((m (length x)))
  29     (or n (setq n 1))
  30     (and (< n m)
  31          (progn
  32            (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
  33            x))))
  34
  35
  36 ;;; @ alist
  37 ;;;
  38
  39 (defun put-alist (item value alist)
  40   "If there is a pair whose car is <ITEM>, replace its cdr by <VALUE>.
  41 If there is not such pair, create new pair (<ITEM> . <VALUE>) and
  42 return new alist whose car is the new pair and cdr is <ALIST>.
  43 [mol's ELIS emulating function]"
  44   (if (assoc item alist)
  45       (progn
  46         (rplacd (assoc item alist) value)
  47         alist)
  48     (cons (cons item value) alist)
  49     ))
  50
  51 (defun del-alist (item alist)
  52   "If there is a pair whose key is <ITEM>, delete it from <ALIST>.
  53 [mol's ELIS emulating function]"
  54   (if (equal item (car (car alist)))
  55       (cdr alist)
  56     (let ((pr alist)
  57           (r (cdr alist))
  58           )
  59       (catch 'tag
  60         (while (not (null r))
  61           (if (equal item (car (car r)))
  62               (progn
  63                 (rplacd pr (cdr r))
  64                 (throw 'tag alist)))
  65           (setq pr r)
  66           (setq r (cdr r))
  67           )
  68         alist))))
  69
  70 (defun set-alist (sym item value)
  71   (if (not (boundp sym))
  72       (set sym nil)
  73     )
  74   (set sym (put-alist item value (eval sym)))
  75   )
  76
  77
  78 ;;; @ field
  79 ;;;
  80
  81 (defun fetch-field (key alist)
  82   (assoc key alist))
  83
  84 (fset 'put-field 'put-alist)
  85 (fset 'delete-field 'del-alist)
  86
  87
  88 ;;; @ field unifier
  89 ;;;
  90
  91 (defun field-unifier-for-default (a b)
  92   (let ((ret
  93          (cond ((equal a b)    a)
  94                ((null (cdr b)) a)
  95                ((null (cdr a)) b)
  96                )))
  97     (if ret
  98         (list nil ret nil)
  99       )))
 100
 101 (defun field-unify (a b)
 102   (let ((sym (symbol-concat "field-unifier-for-" (car a))))
 103     (if (not (fboundp sym))
 104         (setq sym (function field-unifier-for-default))
 105       )
 106     (funcall sym a b)
 107     ))
 108
 109
 110 ;;; @ type unifier
 111 ;;;
 112
 113 (defun assoc-unify (class instance)
 114   (catch 'tag
 115     (let ((cla (copy-alist class))
 116           (ins (copy-alist instance))
 117           (r class)
 118           cell aret ret prev rest)
 119       (while r
 120         (setq cell (car r))
 121         (setq aret (fetch-field (car cell) ins))
 122         (if aret
 123             (if (setq ret (field-unify cell aret))
 124                 (progn
 125                   (if (car ret)
 126                       (setq prev (put-field (car (car ret))
 127                                             (cdr (car ret))
 128                                             prev))
 129                     )
 130                   (if (nth 2 ret)
 131                       (setq rest (put-field (car (nth 2 ret))
 132                                             (cdr (nth 2 ret))
 133                                             rest))
 134                     )
 135                   (setq cla (put-field (car cell)(cdr (nth 1 ret)) cla))
 136                   (setq ins (delete-field (car cell) ins))
 137                   )
 138               (throw 'tag nil)
 139               ))
 140         (setq r (cdr r))
 141         )
 142       (setq r (copy-alist ins))
 143       (while r
 144         (setq cell (car r))
 145         (setq aret (fetch-field (car cell) cla))
 146         (if aret
 147             (if (setq ret (field-unify cell aret))
 148                 (progn
 149                   (if (car ret)
 150                       (setq prev (put-field (car (car ret))
 151                                             (cdr (car ret))
 152                                             prev))
 153                     )
 154                   (if (nth 2 ret)
 155                       (setq rest (put-field (car (nth 2 ret))
 156                                             (cdr (nth 2 ret))
 157                                             rest))
 158                     )
 159                   (setq cla (delete-field (car cell) cla))
 160                   (setq ins (put-field (car cell)(cdr (nth 1 ret)) ins))
 161                   )
 162               (throw 'tag nil)
 163               ))
 164         (setq r (cdr r))
 165         )
 166       (list prev (append cla ins) rest)
 167       )))
 168
 169 (defun get-unified-alist (db al)
 170   (let ((r db) ret)
 171     (catch 'tag
 172       (while r
 173         (if (setq ret (nth 1 (assoc-unify (car r) al)))
 174             (throw 'tag ret)
 175           )
 176         (setq r (cdr r))
 177         ))))
 178
 179 (defun set-atype (sym al)
 180   (if (null (boundp sym))
 181       (set sym al)
 182     (let ((ret (get-unified-alist (eval sym) al)))
 183       (if (not (equal ret al))
 184           (set sym (cons al (eval sym)))
 185         ))))