cl.el

早期freebsd实现

(defun isqrt (number)
  "Return the integer square root of NUMBER.
NUMBER must not be negative.  Result is largest integer less than or
equal to the real square root of the argument."
  (cond
   ((minusp number)
    (error "Argument to `isqrt' must not be negative"))
   ((zerop number)
    0)
   ((<= number 3)
    1)
   (t
    ;; This is some sort of newtonian iteration, trying not to get in
    ;; an infinite loop.  That's why I catch 0, 1, 2 and 3 as special
    ;; cases, so then rounding won't make this iteration loop.
    (do* ((approx (/ number 2) iter)
          (done nil)
          (iter   0))
        (done (if (> (* approx approx) number)
                  (- approx 1)          ;reached from above
                  approx))
      (setq iter
            (/ (+ approx
                  (/ number approx)
                  (if (>= (% number approx) (/ approx 2))
                      1 0))
               2))
      (setq done (eql approx iter))))))

(defun floor (number &optional divisor)
  "Divide DIVIDEND by DIVISOR, rounding toward minus infinity.
DIVISOR defaults to 1.  The remainder is produced as a second value."
  (cond
   ((and (null divisor)                 ; trivial case
         (numberp number))
    (values number 0))
   (t                                   ; do the division
    (multiple-value-bind
        (q r s)
        (safe-idiv number divisor)
      (cond
       ((zerop s)
        (values 0 0))
       ((plusp s)
        (values q r))
       (t
        (unless (zerop r)
          (setq q (- 0 (+ q 1)))
          (setq r (- number (* q divisor))))
        (values q r)))))))

(defun ceiling (number &optional divisor)
  "Divide DIVIDEND by DIVISOR, rounding toward plus infinity.
DIVISOR defaults to 1.  The remainder is produced as a second value."
  (cond
   ((and (null divisor)                 ; trivial case
         (numberp number))
    (values number 0))
   (t                                   ; do the division
    (multiple-value-bind
        (q r s)
        (safe-idiv number divisor)
      (cond
       ((zerop s)
        (values 0 0))
       ((minusp s)
        (values q r))
       (t
        (unless (zerop r)
          (setq q (+ q 1))
          (setq r (- number (* q divisor))))
        (values q r)))))))

(defun truncate (number &optional divisor)
  "Divide DIVIDEND by DIVISOR, rounding toward zero.
DIVISOR defaults to 1.  The remainder is produced as a second value."
  (cond
   ((and (null divisor)                 ; trivial case
         (numberp number))
    (values number 0))
   (t                                   ; do the division
    (multiple-value-bind
        (q r s)
        (safe-idiv number divisor)
      (cond
       ((zerop s)
        (values 0 0))
       ((plusp s)
        (values q r))
       (t
        (unless (zerop r)
          (setq q (- 0 q))
          (setq r (- number (* q divisor))))
        (values q r)))))))

(defun round (number &optional divisor)
  "Divide DIVIDEND by DIVISOR, rounding to nearest integer.
DIVISOR defaults to 1.  The remainder is produced as a second value."
  (cond
   ((and (null divisor)                 ; trivial case
         (numberp number))
    (values number 0))    
   (t                                   ; do the division
    (multiple-value-bind
        (q r s)
        (safe-idiv number divisor)
      (setq r (abs r))
      ;; adjust magnitudes first, and then signs
      (let ((other-r (- (abs divisor) r)))
        (cond
         ((> r other-r)
          (setq q (+ q 1)))
         ((and (= r other-r)
               (oddp q))
          ;; round to even is mandatory
          (setq q (+ q 1))))
        (setq q (* s q))
        (setq r (- number (* q divisor)))
        (values q r))))))

(defun mod (number divisor)
  "Return remainder of X by Y (rounding quotient toward minus infinity).
That is, the remainder goes with the quotient produced by `floor'."
  (multiple-value-bind (q r) (floor number divisor)
    r))

(defun rem (number divisor)
  "Return remainder of X by Y (rounding quotient toward zero).
That is, the remainder goes with the quotient produced by `truncate'."
  (multiple-value-bind (q r) (truncate number divisor)
    r))

;;; internal utilities
;;;
;;; safe-idiv performs an integer division with positive numbers only.
;;; It is known that some machines/compilers implement weird remainder
;;; computations when working with negatives, so the idea here is to
;;; make sure we know what is coming back to the caller in all cases.

(defun safe-idiv (a b)
  "SAFE-IDIV A B => Q R S
Q=|A|/|B|, R is the rest, S is the sign of A/B."
  (unless (and (numberp a) (numberp b))
    (error "Arguments to `safe-idiv' must be numbers"))
  (when (zerop b)
    (error "Cannot divide %d by zero" a))
  (let* ((absa (abs a))
         (absb (abs b))
         (q    (/ absa absb))
         (s    (* (signum a) (signum b)))
         (r    (- a (* (* s q) b))))
    (values q r s)))

;;;; end of cl-arith.el

;;;; SETF
;;;;    This file provides the setf macro and friends. The purpose has
;;;;    been modest, only the simplest defsetf forms are accepted.
;;;;    Use it and enjoy.
;;;;
;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;;       ([e-mail])


(defkeyword :setf-update-fn
  "Property, its value is the function setf must invoke to update a
generalized variable whose access form is a function call of the
symbol that has this property.")

(defkeyword :setf-update-doc
  "Property of symbols that have a `defsetf' update function on them,
installed by the `defsetf' from its optional third argument.")

(defmacro setf (&rest pairs)
  "Generalized `setq' that can set things other than variable values.
A use of `setf' looks like (setf {PLACE VALUE}...).
The behavior of (setf PLACE VALUE) is to access the generalized variable
at PLACE and store VALUE there.  It returns VALUE.  If there is more
than one PLACE and VALUE, each PLACE is set from its VALUE before
the next PLACE is evaluated."
  (let ((nforms (length pairs)))
    ;; check the number of subforms
    (cond
     ((/= (% nforms 2) 0)
      (error "Odd number of arguments to `setf'"))
     ((= nforms 0)
      nil)
     ((> nforms 2)
      ;; this is the recursive case
      (cons 'progn
            (do*                        ;collect the place-value pairs
                ((args pairs (cddr args))
                 (place (car args) (car args))
                 (value (cadr args) (cadr args))
                 (result '()))
                ((endp args) (nreverse result))
              (setq result
                    (cons (list 'setf place value)
                          result)))))
     (t                                 ;i.e., nforms=2
      ;; this is the base case (SETF PLACE VALUE)
      (let* ((place (car pairs))
             (value (cadr pairs))
             (head  nil)
             (updatefn nil))
        ;; dispatch on the type of the PLACE
        (cond
         ((symbolp place)
          (list 'setq place value))
         ((and (listp place)
               (setq head (car place))
               (symbolp head)
               (setq updatefn (get head :setf-update-fn)))
	  (if (or (and (consp updatefn) (eq (car updatefn) 'lambda))
		  (and (symbolp updatefn)
		       (fboundp updatefn)
		       (let ((defn (symbol-function updatefn)))
			 (or (subrp defn)
			     (and (consp defn) (eq (car defn) 'lambda))))))
	      (cons updatefn (append (cdr place) (list value)))
	    (multiple-value-bind
		(bindings newsyms)
		(pair-with-newsyms (append (cdr place) (list value)))
	      ;; this let* gets new symbols to ensure adequate order of
	      ;; evaluation of the subforms.
	      (list 'let
		    bindings              
		    (cons updatefn newsyms)))))
         (t
          (error "No `setf' update-function for `%s'"
                 (prin1-to-string place)))))))))

(defmacro defsetf (accessfn updatefn &optional docstring)
  "Define how `setf' works on a certain kind of generalized variable.
A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]).
ACCESSFN is a symbol.  UPDATEFN is a function or macro which takes
one more argument than ACCESSFN does.  DEFSETF defines the translation
of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL).
The function UPDATEFN must return its last arg, after performing the
updating called for."
  ;; reject ill-formed requests.  too bad one can't test for functionp
  ;; or macrop.
  (when (not (symbolp accessfn))
    (error "First argument of `defsetf' must be a symbol, not `%s'"
           (prin1-to-string accessfn)))
  ;; update properties
  (put accessfn :setf-update-fn updatefn)
  (put accessfn :setf-update-doc docstring))

;;; This section provides the "default" setfs for Common-Emacs-Lisp
;;; The user will not normally add anything to this, although
;;; defstruct will introduce new ones as a matter of fact.
;;;
;;; Apply is a special case.   The Common Lisp
;;; standard makes the case of apply be useful when the user writes
;;; something like (apply #'name ...), Emacs Lisp doesn't have the #
;;; stuff, but it has (function ...).  Notice that V18 includes a new
;;; apply: this file is compatible with V18 and pre-V18 Emacses.

;;; INCOMPATIBILITY: the SETF macro evaluates its arguments in the
;;; (correct) left to right sequence *before* checking for apply
;;; methods (which should really be an special case inside setf).  Due
;;; to this, the lambda expression defsetf'd to apply will succeed in
;;; applying the right function even if the name was not quoted, but
;;; computed!  That extension is not Common Lisp (nor is particularly
;;; useful, I think).

(defsetf apply
  (lambda (&rest args)
    ;; dissasemble the calling form
    ;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too)
    (let* ((fnform (car args))          ;functional form
           (applyargs (append           ;arguments "to apply fnform"
                       (apply 'list* (butlast (cdr args)))
                       (last args)))
           (newupdater nil))            ; its update-fn, if any
      (cond
       ((and (symbolp fnform)
             (setq newupdater (get fnform :setf-update-fn)))
        ;; just do it
        (apply  newupdater applyargs))
       (t
        (error "Can't `setf' to `%s'"
               (prin1-to-string fnform))))))
  "`apply' is a special case for `setf'")


(defsetf aref
  aset
  "`setf' inversion for `aref'")

(defsetf nth
  setnth
  "`setf' inversion for `nth'")

(defsetf nthcdr
  setnthcdr
  "`setf' inversion for `nthcdr'")

(defsetf elt
  setelt
  "`setf' inversion for `elt'")

(defsetf first
  (lambda (list val) (setnth 0 list val))
  "`setf' inversion for `first'")

(defsetf second
  (lambda (list val) (setnth 1 list val))
  "`setf' inversion for `second'")

(defsetf third
  (lambda (list val) (setnth 2 list val))
  "`setf' inversion for `third'")

(defsetf fourth
  (lambda (list val) (setnth 3 list val))
  "`setf' inversion for `fourth'")

(defsetf fifth
  (lambda (list val) (setnth 4 list val))
  "`setf' inversion for `fifth'")

(defsetf sixth
  (lambda (list val) (setnth 5 list val))
  "`setf' inversion for `sixth'")

(defsetf seventh
  (lambda (list val) (setnth 6 list val))
  "`setf' inversion for `seventh'")

(defsetf eighth
  (lambda (list val) (setnth 7 list val))
  "`setf' inversion for `eighth'")

(defsetf ninth
  (lambda (list val) (setnth 8 list val))
  "`setf' inversion for `ninth'")

(defsetf tenth
  (lambda (list val) (setnth 9 list val))
  "`setf' inversion for `tenth'")

(defsetf rest
  (lambda (list val) (setcdr list val))
  "`setf' inversion for `rest'")

(defsetf car setcar "Replace the car of a cons")

(defsetf cdr setcdr "Replace the cdr of a cons")

(defsetf caar
  (lambda (list val) (setcar (nth 0 list) val))
  "`setf' inversion for `caar'")

(defsetf cadr
  (lambda (list val) (setcar (cdr list) val))
  "`setf' inversion for `cadr'")

(defsetf cdar
  (lambda (list val) (setcdr (car list) val))
  "`setf' inversion for `cdar'")

(defs