cl.el

早期freebsd实现

          (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 nil)))))

(defun notevery (pred seq &rest moreseqs)
  "Test PREDICATE on each element of SEQUENCE; is it sometimes 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))
      (unless applyval
        (setq ready t)
        (setq result t)))))



;;; an inverse of elt is needed for setf purposes

(defun setelt (seq n newval)
  "In SEQUENCE, set the Nth element to NEWVAL.  Returns NEWVAL.
A sequence means either a list or a vector."
  (let ((l (length seq)))
    (cond
     ((or (< n 0)
          (>= n l))
      (error "N(%d) should be between 0 and %d" n l))
     (t
      ;; only two cases need be considered
      (cond
       ((listp seq)
        (setnth n seq newval))
       ((arrayp seq)
        (aset seq n newval))
       (t
        (error "SEQ should be a sequence, not `%s'"
               (prin1-to-string seq))))))))

;;; Testing with keyword arguments.
;;;
;;; Many of the sequence functions use keywords to denote some stylized
;;; form of selecting entries in a sequence.  The involved arguments
;;; are collected with a &rest marker (as Emacs Lisp doesn't have a &key
;;; marker), then they are passed to build-klist, who
;;; constructs an association list.  That association list is used to
;;; test for satisfaction and matching.

(defun extract-from-klist (key klist &optional default)
  "EXTRACT-FROM-KLIST KEY KLIST [DEFAULT] => value of KEY or DEFAULT
Extract value associated with KEY in KLIST (return DEFAULT if nil)."
  (let ((retrieved (cdr (assoc key klist))))
    (or retrieved default)))

(defun add-to-klist (key item klist)
  "ADD-TO-KLIST KEY ITEM KLIST => new KLIST
Add association (KEY . ITEM) to KLIST."
  (setq klist (acons key item klist)))

(defun elt-satisfies-test-p (item elt klist)
  "ELT-SATISFIES-TEST-P ITEM ELT KLIST => t or nil
KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
True if the given ITEM and ELT satisfy the test."
  (let ((test     (extract-from-klist :test klist))
        (test-not (extract-from-klist :test-not klist))
        (keyfn    (extract-from-klist :key klist 'identity)))
    (cond
     (test
      (funcall test item (funcall keyfn elt)))
     (test-not
      (not (funcall test-not item (funcall keyfn elt))))
     (t                                 ;should never happen
      (error "Neither :test nor :test-not in `%s'"
             (prin1-to-string klist))))))

(defun elt-satisfies-if-p   (item klist)
  "ELT-SATISFIES-IF-P ITEM KLIST => t or nil
True if an -if style function was called and ITEM satisfies the
predicate under :predicate in KLIST."
  (let ((predicate (extract-from-klist :predicate klist))
        (keyfn     (extract-from-klist :key 'identity)))
    (funcall predicate item (funcall keyfn elt))))

(defun elt-satisfies-if-not-p (item klist)
  "ELT-SATISFIES-IF-NOT-P ITEM KLIST => t or nil
KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
True if an -if-not style function was called and ITEM does not satisfy
the predicate under :predicate in KLIST."
  (let ((predicate (extract-from-klist :predicate klist))
        (keyfn     (extract-from-klist :key 'identity)))
    (not (funcall predicate item (funcall keyfn elt)))))

(defun elts-match-under-klist-p (e1 e2 klist)
  "ELTS-MATCH-UNDER-KLIST-P E1 E2 KLIST => t or nil
KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
True if elements E1 and E2 match under the tests encoded in KLIST."
  (let ((test     (extract-from-klist :test klist))
        (test-not (extract-from-klist :test-not klist))
        (keyfn    (extract-from-klist :key klist 'identity)))
    (cond
     (test
      (funcall test (funcall keyfn e1) (funcall keyfn e2)))
     (test-not
      (not (funcall test-not (funcall keyfn e1) (funcall keyfn e2))))
     (t                                 ;should never happen
      (error "Neither :test nor :test-not in `%s'"
             (prin1-to-string klist))))))

;;;; end of cl-sequences.el

;;;; MULTIPLE VALUES
;;;;    This package approximates the behavior of the multiple-values
;;;;    forms of Common Lisp.  
;;;;
;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;;       ([e-mail])



;;; Lisp indentation information
(put 'multiple-value-bind  'lisp-indent-hook 2)
(put 'multiple-value-setq  'lisp-indent-hook 2)
(put 'multiple-value-list  'lisp-indent-hook nil)
(put 'multiple-value-call  'lisp-indent-hook 1)
(put 'multiple-value-prog1 'lisp-indent-hook 1)


;;; Global state of the package is kept here
(defvar *mvalues-values* nil
  "Most recently returned multiple-values")
(defvar *mvalues-count*  nil
  "Count of multiple-values returned, or nil if the mechanism was not used")

;;; values is the standard multiple-value-return form.  Must be the
;;; last thing evaluated inside a function.  If the caller is not
;;; expecting multiple values, only the first one is passed.  (values)
;;; is the same as no-values returned (unaware callers see nil). The
;;; alternative (values-list <list>) is just a convenient shorthand
;;; and complements multiple-value-list.

(defun values (&rest val-forms)
  "Produce multiple values (zero or more).  Each arg is one value.
See also `multiple-value-bind', which is one way to examine the
multiple values produced by a form.  If the containing form or caller
does not check specially to see multiple values, it will see only
the first value."
  (setq *mvalues-values* val-forms)
  (setq *mvalues-count*  (length *mvalues-values*))
  (car *mvalues-values*))


(defun values-list (&optional val-forms)
  "Produce multiple values (zero or mode).  Each element of LIST is one value.
This is equivalent to (apply 'values LIST)."
  (cond ((nlistp val-forms)
         (error "Argument to values-list must be a list, not `%s'"
                (prin1-to-string val-forms))))
  (setq *mvalues-values* val-forms)
  (setq *mvalues-count* (length *mvalues-values*))
  (car *mvalues-values*))


;;; Callers that want to see the multiple values use these macros.

(defmacro multiple-value-list (form)
  "Execute FORM and return a list of all the (multiple) values FORM produces.
See `values' and `multiple-value-bind'."
  (list 'progn
        (list 'setq '*mvalues-count* nil)
        (list 'let (list (list 'it '(gensym)))
              (list 'set 'it form)
              (list 'if '*mvalues-count*
                    (list 'copy-sequence '*mvalues-values*)
                    (list 'progn
                          (list 'setq '*mvalues-count* 1)
                          (list 'setq '*mvalues-values*
                                (list 'list (list 'symbol-value 'it)))
                          (list 'copy-sequence '*mvalues-values*))))))

(defmacro multiple-value-call (function &rest args)
  "Call FUNCTION on all the values produced by the remaining arguments.
(multiple-value-call '+ (values 1 2) (values 3 4)) is 10."
  (let* ((result (gentemp))
         (arg    (gentemp)))
    (list 'apply (list 'function (eval function))
          (list 'let* (list (list result '()))
                (list 'dolist (list arg (list 'quote args) result)
                      (list 'setq result
                            (list 'append
                                  result
                                  (list 'multiple-value-list
                                        (list 'eval arg)))))))))

(defmacro multiple-value-bind (vars form &rest body)
  "Bind VARS to the (multiple) values produced by FORM, then do BODY.
VARS is a list of variables; each is bound to one of FORM's values.
If FORM doesn't make enough values, the extra variables are bound to nil.
(Ordinary forms produce only one value; to produce more, use `values'.)
Extra values are ignored.
BODY (zero or more forms) is executed with the variables bound,
then the bindings are unwound."
  (let* ((vals   (gentemp))             ;name for intermediate values
         (clauses (mv-bind-clausify     ;convert into clauses usable
                   vars vals)))         ; in a let form
    (list* 'let*
           (cons (list vals (list 'multiple-value-list form))
                 clauses)
           body)))

(defmacro multiple-value-setq (vars form)
  "Set VARS to the (multiple) values produced by FORM.
VARS is a list of variables; each is set to one of FORM's values.
If FORM doesn't make enough values, the extra variables are set to nil.
(Ordinary forms produce only one value; to produce more, use `values'.)
Extra values are ignored."
  (let* ((vals (gentemp))               ;name for intermediate values
         (clauses (mv-bind-clausify     ;convert into clauses usable
                   vars vals)))         ; in a setq (after append).
    (list 'let*
          (list (list vals (list 'multiple-value-list form)))
          (cons 'setq (apply (function append) clauses)))))

(defmacro multiple-value-prog1 (form &rest body)
  "Evaluate FORM, then BODY, then produce the same values FORM produced.
Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2.
This is like `prog1' except that `prog1' would produce only one value,
which would be the first of FORM's values."
  (let* ((heldvalues (gentemp)))
    (cons 'let*
          (cons (list (list heldvalues (list 'multiple-value-list form)))
                (append body (list (list 'values-list heldvalues)))))))

;;; utility functions
;;;
;;; mv-bind-clausify makes the pairs needed to have the variables in
;;; the variable list correspond with the values returned by the form.
;;; vals is a fresh symbol that intervenes in all the bindings.

(defun mv-bind-clausify (vars vals)
  "MV-BIND-CLAUSIFY VARS VALS => Auxiliary list
Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to
the length of VARS (a list of symbols).  VALS is just a fresh symbol."
  (if (or (nlistp vars)
          (notevery 'symbolp vars))
      (error "Expected a list of symbols, not `%s'"
             (prin1-to-string vars)))
  (let* ((nvars    (length vars))
         (clauses '()))
    (dotimes (n nvars clauses)
      (setq clauses (cons (list (nth n vars)
                                (list 'nth n vals)) clauses)))))

;;;; end of cl-multiple-values.el

;;;; ARITH
;;;;    This file provides integer arithmetic extensions.  Although
;;;;    Emacs Lisp doesn't really support anything but integers, that
;;;;    has still to be made to look more or less standard.
;;;;
;;;;
;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;;       ([e-mail])


(defun plusp (number)
  "True if NUMBER is strictly greater than zero."
  (> number 0))

(defun minusp (number)
  "True if NUMBER is strictly less than zero."
  (< number 0))

(defun oddp (number)
  "True if INTEGER is not divisible by 2."
  (/= (% number 2) 0))

(defun evenp (number)
  "True if INTEGER is divisible by 2."
  (= (% number 2) 0))

(defun abs (number)
  "Return the absolute value of NUMBER."
  (cond
   ((< number 0)
    (- 0 number))
   (t                                   ;number is >= 0
    number)))

(defun signum (number)
  "Return -1, 0 or 1 according to the sign of NUMBER."
  (cond
   ((< number 0)
    -1)
   ((> number 0)
    1)
   (t                                   ;exactly zero
    0)))

(defun gcd (&rest integers)
  "Return the greatest common divisor of all the arguments.
The arguments must be integers.  With no arguments, value is zero."
  (let ((howmany (length integers)))
    (cond
     ((= howmany 0)
      0)
     ((= howmany 1)
      (abs (car integers)))
     ((> howmany 2)
      (apply (function gcd)
       (cons (gcd (nth 0 integers) (nth 1 integers))
             (nthcdr 2 integers))))
     (t                                 ;howmany=2
      ;; essentially the euclidean algorithm
      (when (zerop (* (nth 0 integers) (nth 1 integers)))
        (error "A zero argument is invalid for `gcd'"))
      (do* ((absa (abs (nth 0 integers))) ; better to operate only
            (absb (abs (nth 1 integers))) ;on positives.
            (dd (max absa absb))        ; setup correct order for the
            (ds (min absa absb))        ;succesive divisions.
            ;; intermediate results
            (q 0)
            (r 0)
            ;; final results
            (done nil)                  ; flag: end of iterations
            (result 0))                 ; final value
          (done result)
        (setq q (/ dd ds))
        (setq r (% dd ds))
        (cond 
         ((zerop r) (setq done t) (setq result ds))
         ( t        (setq dd ds)  (setq ds r))))))))

(defun lcm (integer &rest more)
  "Return the least common multiple of all the arguments.
The arguments must be integers and there must be at least one of them."
  (let ((howmany (length more))
        (a       integer)
        (b       (nth 0 more))
        prod                            ; intermediate product
        (yetmore (nthcdr 1 more)))
    (cond
     ((zerop howmany)
      (abs a))
     ((> howmany 1)                     ; recursive case
      (apply (function lcm)
             (cons (lcm a b) yetmore)))
     (t                                 ; base case, just 2 args
      (setq prod (* a b))
      (cond
       ((zerop prod)
        0)
       (t
        (/ (abs prod) (gcd a b))))))))