;;;;  interlist.el
;;;;		Some nice functions ported from InterLISP
;;;;
;;;;
;;;;  Copyright (C) 1993	Thomas Bellman,
;;;;				Lysator Computer Club,
;;;;				Linkoping University,  Sweden
;;;;
;;;;  Everyone is granted permission to copy, modify and redistribute
;;;;  this code, provided the people they give it to can.
;;;;
;;;;
;;;;  Author:	Thomas Bellman
;;;;		Lysator Computer Club
;;;;		Linkoping University
;;;;		Sweden
;;;;
;;;;  email:	Bellman@Lysator.LiU.Se
;;;;
;;;;
;;;;  Any opinions expressed in this code are the author's PERSONAL opinions,
;;;;  and does NOT, repeat NOT, represent any official standpoint of Lysator,
;;;;  even if so stated.



(provide 'interlist)


(defmacro caar (list) (` (car (car (, list)))))
(defmacro cadr (list) (` (car (cdr (, list)))))
(defmacro cdar (list) (` (cdr (car (, list)))))
(defmacro cddr (list) (` (cdr (cdr (, list)))))
(defmacro caaar (list) (` (car (car (car (, list))))))
(defmacro caadr (list) (` (car (car (cdr (, list))))))
(defmacro cadar (list) (` (car (cdr (car (, list))))))
(defmacro caddr (list) (` (car (cdr (cdr (, list))))))
(defmacro cdaar (list) (` (cdr (car (car (, list))))))
(defmacro cdadr (list) (` (cdr (car (cdr (, list))))))
(defmacro cddar (list) (` (cdr (cdr (car (, list))))))
(defmacro cdddr (list) (` (cdr (cdr (cdr (, list))))))

(defmacro caaaar (list) (` (car (car (car (car (, list)))))))
(defmacro caaadr (list) (` (car (car (car (cdr (, list)))))))
(defmacro caadar (list) (` (car (car (cdr (car (, list)))))))
(defmacro caaddr (list) (` (car (car (cdr (cdr (, list)))))))
(defmacro cadaar (list) (` (car (cdr (car (car (, list)))))))
(defmacro cadadr (list) (` (car (cdr (car (cdr (, list)))))))
(defmacro caddar (list) (` (car (cdr (cdr (car (, list)))))))
(defmacro cadddr (list) (` (car (cdr (cdr (cdr (, list)))))))

(defmacro cdaaar (list) (` (cdr (car (car (car (, list)))))))
(defmacro cdaadr (list) (` (cdr (car (car (cdr (, list)))))))
(defmacro cdadar (list) (` (cdr (car (cdr (car (, list)))))))
(defmacro cdaddr (list) (` (cdr (car (cdr (cdr (, list)))))))
(defmacro cddaar (list) (` (cdr (cdr (car (car (, list)))))))
(defmacro cddadr (list) (` (cdr (cdr (car (cdr (, list)))))))
(defmacro cdddar (list) (` (cdr (cdr (cdr (car (, list)))))))
(defmacro cddddr (list) (` (cdr (cdr (cdr (cdr (, list)))))))



(defun attach (elem list)
  "Attaches the element ELEM to the front of the list LIST.
Physically modifies LIST.  Returns the new value of LIST, which is
the same as (cons ELEM LIST).  LIST must not be nil."

  (rplacd list (cons (car list) (cdr list)))
  (rplaca list elem)
  list)


(defun dremove1st (list)
  "Destructive removal of the first element of the list LIST.
Note:  If the resulting list would be nil, dremove1st returns nil, but
the list is not modified."
  (if (null (cdr list))
      nil
    (rplaca list (cadr list))
    (rplacd list (cddr list))
    list))



(defun putassoc (key val alist)
  "Puts an assoc pair with key KEY and value VAL in the assoc list ALIST.
Replaces an old assoc pair with the key KEY if it exists, or adds a
new pair at the beginning of ALIST.  Comparison of keys are made with
equal.  ALIST must not be nil."
  (let ((pair (assoc key alist)))
    (if pair
	(progn
	  (rplacd pair val)
	  pair)
      (progn
	(attach (cons key val) alist)
	(car alist)))))



(defun putassq (key val alist)
  "Puts an assoc pair with key KEY and value VAL in the assoc list ALIST.
Replaces an old assoc pair with the key KEY if it exists, or adds a
new pair at the beginning of ALIST.  Comparison of keys are made with
eq.  ALIST must not be nil."
  (let ((pair (assq key alist)))
    (if pair
	(progn
	  (rplacd pair val)
	  pair)
      (progn
	(attach (cons key val) alist)
	(car alist)))))



(defun tconc (ptr elem)
  "To the end of the list PTR, add the element ELEM.
PTR should be initialized by calling (setq foo (tconc nil ELEM1)),
or by calling (progn (setq foo (cons nil nil)) (tconc foo ELEM1)).
This initializes foo to be a cons between a list (car part of foo),
and a pointer to the end of the list (cdr part of foo).  Then, just
call (tconc foo ELEMn) to add an element to the end of the list.
Value is always new PTR.
Note that the actual list is in (car PTR)."
  (cond
   ((eq ptr nil) (setq ptr (cons (cons elem nil) nil))
		 (rplacd ptr (car ptr))
		 ptr)
   ((equal ptr (cons nil nil)) (rplaca ptr (cons elem nil))
			       (rplacd ptr (car ptr))
			       ptr)
   (t (rplacd (cdr ptr) (cons elem nil))
      (rplacd ptr (cdr (cdr ptr)))
      ptr)))