cl.el

早期freebsd实现

     (function (lambda (component)
                 (if (nlistp component)
                     (error "Components of `loop' should be lists"))))
     body)
    ;; build the infinite loop
    (cons 'while (cons 't body))))

;;;; end of cl-iterations.el

;;;; LISTS
;;;;    This file provides some of the lists machinery of Common-Lisp
;;;;    in a way compatible with Emacs Lisp.  Especially, see the the
;;;;    typical c[ad]*r functions.
;;;;
;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;;       ([e-mail])



;;; Synonyms for list functions
(defun first (x)
  "Synonym for `car'"
  (car x))

(defun second (x)
  "Return the second element of the list LIST."
  (nth 1 x))

(defun third (x)
  "Return the third element of the list LIST."
  (nth 2 x))

(defun fourth (x)
  "Return the fourth element of the list LIST."
  (nth 3 x))

(defun fifth (x)
  "Return the fifth element of the list LIST."
  (nth 4 x))

(defun sixth (x)
  "Return the sixth element of the list LIST."
  (nth 5 x))

(defun seventh (x)
  "Return the seventh element of the list LIST."
  (nth 6 x))

(defun eighth (x)
  "Return the eighth element of the list LIST."
  (nth 7 x))

(defun ninth (x)
  "Return the ninth element of the list LIST."
  (nth 8 x))

(defun tenth (x)
  "Return the tenth element of the list LIST."
  (nth 9 x))

(defun rest (x)
  "Synonym for `cdr'"
  (cdr x))

(defun endp (x)
  "t if X is nil, nil if X is a cons; error otherwise."
  (if (listp x)
      (null x)
    (error "endp received a non-cons, non-null argument `%s'"
	   (prin1-to-string x))))

(defun last (x)
  "Returns the last link in the list LIST."
  (if (nlistp x)
      (error "Arg to `last' must be a list"))
  (do ((current-cons    x       (cdr current-cons))
       (next-cons    (cdr x)    (cdr next-cons)))
      ((endp next-cons) current-cons)))

(defun list-length (x)                  ;taken from CLtL sect. 15.2
  "Returns the length of a non-circular list, or `nil' for a circular one."
  (do ((n 0)                            ;counter
       (fast x (cddr fast))             ;fast pointer, leaps by 2
       (slow x (cdr slow))              ;slow pointer, leaps by 1
       (ready nil))                     ;indicates termination
      (ready n)
    (cond
     ((endp fast)
      (setq ready t))                   ;return n
     ((endp (cdr fast))
      (setq n (+ n 1))
      (setq ready t))                   ;return n+1
     ((and (eq fast slow) (> n 0))
      (setq n nil)
      (setq ready t))                   ;return nil
     (t
      (setq n (+ n 2))))))              ;just advance counter

(defun member (item list)
  "Look for ITEM in LIST; return first link in LIST whose car is `eql' to ITEM."
  (let ((ptr list)
        (done nil)
        (result '()))
    (while (not (or done (endp ptr)))
      (cond ((eql item (car ptr))
             (setq done t)
             (setq result ptr)))
      (setq ptr (cdr ptr)))
    result))

(defun butlast (list &optional n)
  "Return a new list like LIST but sans the last N elements.
N defaults to 1.  If the list doesn't have N elements, nil is returned."
  (if (null n) (setq n 1))
  (reverse (nthcdr n (reverse list))))

(defun list* (arg &rest others)
  "Return a new list containing the first arguments consed onto the last arg.
Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)."
  (if (null others)
      arg
    (let* ((allargs (cons arg others))
           (front   (butlast allargs))
           (back    (last allargs)))
      (rplacd (last front) (car back))
      front)))

(defun adjoin (item list)
  "Return a list which contains ITEM but is otherwise like LIST.
If ITEM occurs in LIST, the value is LIST.  Otherwise it is (cons ITEM LIST).
When comparing ITEM against elements, `eql' is used."
  (cond
   ((member item list)
    list)
   (t
    (cons item list))))

(defun ldiff (list sublist)
  "Return a new list like LIST but sans SUBLIST.
SUBLIST must be one of the links in LIST; otherwise the value is LIST itself."
  (do ((result '())
       (curcons list (cdr curcons)))
      ((or (endp curcons) (eq curcons sublist))
       (reverse result))
    (setq result (cons (car curcons) result))))

;;; The popular c[ad]*r functions.

(defun caar (X)
  "Return the car of the car of X."
  (car (car X)))

(defun cadr (X)
  "Return the car of the cdr of X."
  (car (cdr X)))

(defun cdar (X)
  "Return the cdr of the car of X."
  (cdr (car X)))

(defun cddr (X)
  "Return the cdr of the cdr of X."
  (cdr (cdr X)))

(defun caaar (X)
  "Return the car of the car of the car of X."
  (car (car (car X))))

(defun caadr (X)
  "Return the car of the car of the cdr of X."
  (car (car (cdr X))))

(defun cadar (X)
  "Return the car of the cdr of the car of X."
  (car (cdr (car X))))

(defun cdaar (X)
  "Return the cdr of the car of the car of X."
  (cdr (car (car X))))

(defun caddr (X)
  "Return the car of the cdr of the cdr of X."
  (car (cdr (cdr X))))

(defun cdadr (X)
  "Return the cdr of the car of the cdr of X."
  (cdr (car (cdr X))))

(defun cddar (X)
  "Return the cdr of the cdr of the car of X."
  (cdr (cdr (car X))))

(defun cdddr (X)
  "Return the cdr of the cdr of the cdr of X."
  (cdr (cdr (cdr X))))

(defun caaaar (X)
  "Return the car of the car of the car of the car of X."
  (car (car (car (car X)))))

(defun caaadr (X)
  "Return the car of the car of the car of the cdr of X."
  (car (car (car (cdr X)))))

(defun caadar (X)
  "Return the car of the car of the cdr of the car of X."
  (car (car (cdr (car X)))))

(defun cadaar (X)
  "Return the car of the cdr of the car of the car of X."
  (car (cdr (car (car X)))))

(defun cdaaar (X)
  "Return the cdr of the car of the car of the car of X."
  (cdr (car (car (car X)))))

(defun caaddr (X)
  "Return the car of the car of the cdr of the cdr of X."
  (car (car (cdr (cdr X)))))

(defun cadadr (X)
  "Return the car of the cdr of the car of the cdr of X."
  (car (cdr (car (cdr X)))))

(defun cdaadr (X)
  "Return the cdr of the car of the car of the cdr of X."
  (cdr (car (car (cdr X)))))

(defun caddar (X)
  "Return the car of the cdr of the cdr of the car of X."
  (car (cdr (cdr (car X)))))

(defun cdadar (X)
  "Return the cdr of the car of the cdr of the car of X."
  (cdr (car (cdr (car X)))))

(defun cddaar (X)
  "Return the cdr of the cdr of the car of the car of X."
  (cdr (cdr (car (car X)))))

(defun cadddr (X)
  "Return the car of the cdr of the cdr of the cdr of X."
  (car (cdr (cdr (cdr X)))))

(defun cddadr (X)
  "Return the cdr of the cdr of the car of the cdr of X."
  (cdr (cdr (car (cdr X)))))

(defun cdaddr (X)
  "Return the cdr of the car of the cdr of the cdr of X."
  (cdr (car (cdr (cdr X)))))

(defun cdddar (X)
  "Return the cdr of the cdr of the cdr of the car of X."
  (cdr (cdr (cdr (car X)))))

(defun cddddr (X)
  "Return the cdr of the cdr of the cdr of the cdr of X."
  (cdr (cdr (cdr (cdr X)))))

;;; some inverses of the accessors are needed for setf purposes

(defun setnth (n list newval)
  "Set (nth N LIST) to NEWVAL.  Returns NEWVAL."
  (rplaca (nthcdr n list) newval))

(defun setnthcdr (n list newval)
  "SETNTHCDR N LIST NEWVAL => NEWVAL
As a side effect, sets the Nth cdr of LIST to NEWVAL."
  (cond
   ((< n 0)
    (error "N must be 0 or greater, not %d" n))
   ((= n 0)
    (rplaca list (car newval))
    (rplacd list (cdr newval))
    newval)
   (t
    (rplacd (nthcdr (- n 1) list) newval))))

;;; A-lists machinery

(defun acons (key item alist)
  "Return a new alist with KEY paired with ITEM; otherwise like ALIST.
Does not copy ALIST."
  (cons (cons key item) alist))

(defun pairlis (keys data &optional alist)
  "Return a new alist with each elt of KEYS paired with an elt of DATA;
optional 3rd arg ALIST is nconc'd at the end.  KEYS and DATA must
have the same length."
  (unless (= (length keys) (length data))
    (error "Keys and data should be the same length"))
  (do* ;;collect keys and data in front of alist
      ((kptr keys (cdr kptr))           ;traverses the keys
       (dptr data (cdr dptr))           ;traverses the data
       (key (car kptr) (car kptr))      ;current key
       (item (car dptr) (car dptr))     ;current data item
       (result alist))
      ((endp kptr) result)
    (setq result (acons key item result))))

;;;; end of cl-lists.el

;;;; SEQUENCES
;;;; Emacs Lisp provides many of the 'sequences' functionality of
;;;; Common Lisp.  This file provides a few things that were left out.
;;;; 


(defkeyword :test      "Used to designate positive (selection) tests.")
(defkeyword :test-not  "Used to designate negative (rejection) tests.")
(defkeyword :key       "Used to designate component extractions.")
(defkeyword :predicate "Used to define matching of sequence components.")
(defkeyword :start     "Inclusive low index in sequence")
(defkeyword :end       "Exclusive high index in sequence")
(defkeyword :start1    "Inclusive low index in first of two sequences.")
(defkeyword :start2    "Inclusive low index in second of two sequences.")
(defkeyword :end1      "Exclusive high index in first of two sequences.")
(defkeyword :end2      "Exclusive high index in second of two sequences.")
(defkeyword :count     "Number of elements to affect.")
(defkeyword :from-end  "T when counting backwards.")

(defun some     (pred seq &rest moreseqs)
  "Test PREDICATE on each element of SEQUENCE; is it ever non-nil?
Extra args are additional sequences; PREDICATE gets one arg from each
sequence and we advance down all the sequences together in lock-step.
A sequence means either a list or a vector."
  (let ((args  (reassemble-argslists (list* seq moreseqs))))
    (do* ((ready nil)                   ;flag: return when t
          (result nil)                  ;resulting value
          (applyval nil)                ;result of applying pred once
          (remaining args
                     (cdr remaining))   ;remaining argument sets
          (current (car remaining)      ;current argument set
                   (car remaining)))
        ((or ready (endp remaining)) result)
      (setq applyval (apply pred current))
      (when applyval
        (setq ready t)
        (setq result applyval)))))

(defun every    (pred seq &rest moreseqs)
  "Test PREDICATE on each element of SEQUENCE; is it always non-nil?
Extra args are additional sequences; PREDICATE gets one arg from each
sequence and we advance down all the sequences together in lock-step.
A sequence means either a list or a vector."
  (let ((args  (reassemble-argslists (list* seq moreseqs))))
    (do* ((ready nil)                   ;flag: return when t
          (result t)                    ;resulting value
          (applyval nil)                ;result of applying pred once
          (remaining args
                     (cdr remaining))   ;remaining argument sets
          (current (car remaining)      ;current argument set
                   (car remaining)))
        ((or ready (endp remaining)) result)
      (setq applyval (apply pred current))
      (unless applyval
        (setq ready t)
        (setq result nil)))))

(defun notany   (pred seq &rest moreseqs)
  "Test PREDICATE on each element of SEQUENCE; is it always nil?
Extra args are additional sequences; PREDICATE gets one arg from each
sequence and we advance down all the sequences together in lock-step.
A sequence means either a list or a vector."
  (let ((args  (reassemble-argslists (list* seq moreseqs))))
    (do* ((ready nil)                   ;flag: return when t
          (result t)                    ;resulting value