;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:10; Readtable:ZL -*-

;;;     A number of the more complicated list functions in this file
;;; use a list accumulation hack to build new lists.  Near as I can
;;; tell, this is the thing that requires the fewest operations.
;;; It requires fewer operations than building a list with something
;;; like PUSH and then returning NREVERSE of it for the value.
;;; I only guessed that it would be more efficient than a "build it
;;; from the bottom up" implementation.
;;;     The basic idea is to build the resulting list from the top down
;;; By REPLACDing onto the end.  You keep a handle on the first cons
;;; to return later.  You also keep a pointer to the last cons of
;;; the list so that you can RPLACD it.  The one minor piece of
;;; difficulty is in getting the initial cons of the new list.  It
;;; is unreasonable to just check to see if the tail pointer variable
;;; is initialized to decide if the initialization or the regular
;;; RPLACD thing should happen because the test for that adds several
;;; instructions to each accumulation (and therefore, to the inside
;;; of the loop).  What we have to do then is figure out what the
;;; first element of the result list is before the regular loop
;;; and put it in the car of a cons cell that the accumulator
;;; function or macro can then RPLACD into.  The most complicated
;;; example of this technique is APPEND, which has to look hard
;;; for the first element of the list which is to be its result.


;;; This is the clever version of length that detects circularity
(defun LIST-LENGTH (list)
  (do ((n 0 (+ n 2))
       (y list (cddr y))
       (x list (cdr x)))
      (())
    (when (atom y) (return n))
    (when (atom (cdr y)) (return (1+ n)))
    (when (and (eq x y) (plusp n)) (return nil))))


;;; the first few of FIRST through NINTH are worth open-coding:

(defun FIRST (list)
  (cons:%car list))

(defsetf FIRST CONS:SET-CAR)

(defun SECOND (list)
  (cons:%car (cons:%cdr list)))

(defun THIRD (list)
  (cons:%car (cons:%cdr (cons:%cdr list))))

(defun FOURTH (list)
  (cons:%car (cons:%cdr (cons:%cdr (cons:%cdr list)))))

(defun FIFTH (list)
  (cons:%car (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr list))))))

(defun SIXTH (list)
  (cons:%car (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr list)))))))

(defun SEVENTH (list)
  (cons:%car (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr list))))))))

(defun EIGHTH (list)
  (cons:%car (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr list)))))))))

(defun NINTH (list)
  (cons:%car (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr list))))))))))

(defun TENTH (list)
  (cons:%car
    (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr (cons:%cdr list)))))))))))

(defsubst REST (list)
  (cdr list))

(defun LAST (list)
  (do* ((l list next)
	(next (cdr l) (cdr l)))
       ((endp next)
	l)))		;was (CAR L)! RG 9/20/87
 
(defun careless-nthcdr (n list)
  (cond ((endp list)	nil)
	((zerop n)	list)
	(t		(careless-nthcdr (1- n) (cons:%cdr list)))))

(defun NTH (n list)
  (when (< n 0)
    (error "The count argument to NTH is negative"))
  (car (careless-nthcdr n list)))

(defun NTHCDR (n list)
  (when (< n 0)
    (error "The count argument to NTHCDR is negative"))
  (careless-nthcdr n list))


(defun MAKE-LIST (size &key (initial-element nil))
  (let ((value nil))
    (dotimes (i size)
      (push initial-element value))
    value))

(defun LIST (&rest args)
  args)						;I'm told &REST arguments are consed in the heap

;;; LIST 2,3,4,N are for the rewriter...

(defun LIST2 (arg1 arg2)
  (cons arg1 (cons arg2 nil)))

(defun LIST3 (arg1 arg2 arg3)
  (cons arg1 (cons arg2 (cons arg3 nil))))

(defun LIST4 (arg1 arg2 arg3 arg4)
  (cons arg1 (cons arg2 (cons arg3 (cons arg4 nil)))))

(defun LISTN (&rest args)
  args)

;;;Changed by WKF on 4/5/88 to use &REST argument since it is consed in the heap.
(defun LIST* (&rest args)
  (cond ((null args) nil)
	((null (cdr args))
	 (car args))
	(t (do ((prevsub args sublist)
		(sublist (cdr args) (cdr sublist)))
	       ((null (cdr sublist))
		(rplacd prevsub (car sublist))
		args)))))

;;;Added by WKF on 4/5/88 as part of microcode port from lambda to K.
(defun LIST-IN-AREA (area-number &rest args)
  (cond ((null args) nil)
	((null (cdr args))
	 (ncons-in-area (car args) area-number))
	(t (let* ((value (ncons-in-area (first args) area-number))
		  (pointer value))
	     (do ((sublist (cdr args) (cdr sublist)))
		 ((null (cdr sublist))
		  (rplacd pointer (ncons-in-area (car sublist) area-number)))
	       (%set-cdr pointer (setq pointer (ncons-in-area (car sublist) area-number)) pointer))
	     value)) ))

;;;Added by WKF on 4/5/88 as part of microcode port from lambda to K.
(defun LIST*-IN-AREA (area-number &rest args)
  (cond ((null args) nil)
	((null (cdr args))
	 (car args))
	(t (let* ((value (ncons-in-area (first args) area-number))
		  (pointer value))
	     (do ((sublist (cdr args) (cdr sublist)))
		 ((null (cdr sublist))
		  (rplacd pointer (car sublist)))	;last argument becomes the tail
	       (%set-cdr pointer (setq pointer (ncons-in-area (car sublist) area-number)) pointer))
	     value)) ))

(defun ACONS (key datum alist)
  (cons (cons key datum) alist))

(defun COPY-LIST (list)
  (cond ((null list) nil)
	((atom list) list)
	(t (let* ((value (cons (first list) nil))
		  (pointer value))
	     (do ((l (cdr list) (cdr l)))
		 ((cond ((null l) t)
			((atom l) (rplacd pointer l))
			(t nil)))
	       (let ((new-cons (cons (car l) nil)))
		 (rplacd pointer new-cons)
		 (setq pointer new-cons)))
	     value)) ))

(defun COPY-ALIST (alist)
  (mapcar #'(lambda (element)
	      (if (consp element)
		  (cons (car element) (cdr element))
		element))
	  alist))

(defun COPY-TREE (tree)
  (if (consp tree)
      (cons (copy-tree (car tree))
	    (copy-tree (cdr tree)))
    tree))


(defun LIST-REVERSE (list)
  (let ((value nil))
    (dolist (element list)
      (push element value))
    value))

(defun LIST-NREVERSE (list)
  (if (endp list)			;his test probably isn't needed
      nil
    (do* ((prev-l nil l)
	  (l list next-l)
	  (next-l (cdr l) (cdr next-l)))
	 ((endp next-l) (rplacd l prev-l) l)
      (format t "~&~a ~a ~a" prev-l l next-l)
      (rplacd l prev-l))))

;;; If you don't understand this, read the comment at the beginning of this file.

(defun APPEND (&rest lists)
  (loop (unless lists
	  (return-from append nil))
	(when (car lists)			;find first non-null list
	  (return))
	(setq lists (cdr lists)))
  (if (cdr lists)
      (let* ((value (cons (caar lists) nil))
	     (pointer value))
	(do* ((lists lists (cdr lists))
	      (this-list (cdar lists) (car lists)))
	     ((null (cdr lists))
	      (setf (cdr pointer) (car lists)))
	  (dolist (element this-list)
	    (setf (cdr pointer) (cons element nil))
	    (setq pointer (cdr pointer))))
	value)
    (car lists)))

(defun REVAPPEND (reverse-list new-tail)
  "Equivalent to (append (reverse REVERSE-LIST) NEW-TAIL)."
  (let ((value new-tail))
    (dolist (element reverse-list)
      (push element value))
    value))

(defun NCONC (&rest lists)
  (cond ((null lists) nil)
	(t (do* ((lists lists (cdr lists))
		 (this-list (car lists) (car lists)))
		((null lists))
	     (when this-list
	       (rplacd (last this-list) (second lists))))
	   (car lists))))

(defun NRECONC (reverse-list new-tail)
  "Equivalent to (nconc (nreverse REVERSE-LIST) NEW-TAIL)."
  (if (endp reverse-list)
      new-tail
    (do* ((previous-cons new-tail
			 this-cons)
	  (this-cons reverse-list next-cons)
	  (next-cons (cdr this-cons)
		     (cdr next-cons)))
	 ((endp next-cons)
	  (rplacd this-cons previous-cons)
	  this-cons)
      (rplacd this-cons previous-cons))))


(defun BUTLAST (list &optional (n 1))
  "Returns a list which has all the elements of LIST except the last N ones."
  (let ((length (list-length list)))
    (cond ((< n 0)
	   (error "The numeric argument to BUTLAST is negative"))
	  ((>= n length) nil)
	  (t (let* ((value (cons (first list) nil))
		    (tail-pointer value))
	       (macrolet ((accumulate (thing)
			    `(let ((new-cons (cons ,thing nil)))
			       (rplacd tail-pointer new-cons)
			       (setq tail-pointer new-cons))))
		 (do ((list (cdr list) (cdr list))
		      (i (- length n 1) (1- i)))
		     ((zerop i))
		   (accumulate (car list))))
	       value)))))

(defun NBUTLAST (list &optional (n 1))
  (let ((new-length (- (list-length list) n)))
    (cond ((< n 0) (error "The numeric argument to NBUTLAST is negative"))
	  ((<= new-length 0) nil)
	  (t (rplacd (nthcdr (1- new-length) list) nil)
	     list))))

(defun LDIFF (list sublist)
  (cond ((null list) nil)
	((eq list sublist) nil)
	(t (let* ((value (cons (first list) nil))
		  (tail-pointer value))
	     (do ((list (cdr list) (cdr list)))
		 ((or (null list)
		      (eq list sublist)))
	       (let ((new-cons (cons (car list) nil)))
		 (rplacd tail-pointer new-cons)
		 (setq tail-pointer new-cons)))
	     value))))

(defun TAILP (sublist list)
  (do ((list list (cdr list)))
      ((null list) nil)
    (when (eq sublist list)
      (return t))))


(defun PAIRLIS (keys data &optional alist)
  (let ((new alist))
    (do ((k keys (cdr k))
	 (d data (cdr d)))
	((or (null k) (null d)))
      (push (cons (car k) (car d)) new))
    new))