tl-list.el

   1 ;;;
   2 ;;; $Id: tl-list.el,v 0.6 1994/08/28 17:10:12 morioka Exp $
   3 ;;;
   4
   5 (provide 'tl-list)
   6
   7 ;;; @ list
   8 ;;;
   9
  10 (defun last (list)
  11   "Returns the last element in the list <LIST>.
  12 [mol's Common Lisp emulating function]"
  13   (nthcdr (- (length list) 1) list)
  14   )
  15
  16 (defun butlast (x &optional n)
  17   "Returns a copy of LIST with the last N elements removed.
  18 [tl-list.el: imported from cl.el]"
  19   (if (and n (<= n 0)) x
  20     (nbutlast (copy-sequence x) n)))
  21
  22 (defun nbutlast (x &optional n)
  23   "Modifies LIST to remove the last N elements.
  24 [tl-list.el: imported from cl.el]"
  25   (let ((m (length x)))
  26     (or n (setq n 1))
  27     (and (< n m)
  28          (progn
  29            (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
  30            x))))
  31
  32
  33 ;;; @ alist
  34 ;;;
  35
  36 (defun put-alist (item value alist)
  37   "If there is a pair whose car is <ITEM>, replace its cdr by <VALUE>.
  38 If there is not such pair, create new pair (<ITEM> . <VALUE>) and
  39 return new alist whose car is the new pair and cdr is <ALIST>.
  40 [mol's ELIS emulating function]"
  41   (if (assoc item alist)
  42       (progn
  43         (rplacd (assoc item alist) value)
  44         alist)
  45     (cons (cons item value) alist)
  46     ))
  47
  48 (defun del-alist (item alist)
  49   "If there is a pair whose key is <ITEM>, delete it from <ALIST>.
  50 [mol's ELIS emulating function]"
  51   (if (equal item (car (car alist)))
  52       (cdr alist)
  53     (let ((pr alist)
  54           (r (cdr alist))
  55           )
  56       (catch 'tag
  57         (while (not (null r))
  58           (if (equal item (car (car r)))
  59               (progn
  60                 (rplacd pr (cdr r))
  61                 (throw 'tag alist)))
  62           (setq pr r)
  63           (setq r (cdr r))
  64           )
  65         alist))))
  66
  67
  68 ;;; @ field
  69 ;;;
  70
  71 (defun fetch-field (key alist)
  72   (assoc key alist))
  73
  74 (fset 'put-field 'put-alist)
  75 (fset 'delete-field 'del-alist)