cl.el

早期freebsd实现

(defmacro when (condition &rest body)
  "(when CONDITION . BODY) => evaluate BODY if CONDITION is true."
  (list* 'if (list 'not condition) '() body))

(defmacro unless (condition &rest body)
  "(unless CONDITION . BODY) => evaluate BODY if CONDITION is false."
  (list* 'if condition '() body))

;;; CASE and ECASE
;;; CASE selects among several clauses, based on the value (evaluated)
;;; of a expression and a list of (unevaluated) key values.  ECASE is
;;; the same, but signals an error if no clause is activated.

(defmacro case (expr &rest cases)
  "(case EXPR . CASES) => evals EXPR, chooses from CASES on that value.
EXPR   -> any form
CASES  -> list of clauses, non empty
CLAUSE -> HEAD . BODY
HEAD   -> t             = catch all, must be last clause
       -> otherwise     = same as t
       -> nil           = illegal
       -> atom          = activated if (eql  EXPR HEAD)
       -> list of atoms = activated if (member EXPR HEAD)
BODY   -> list of forms, implicit PROGN is built around it.
EXPR is evaluated only once."
  (let* ((newsym (gentemp))
         (clauses (case-clausify cases newsym)))
    ;; convert case into a cond inside a let
    (list 'let
         (list (list newsym expr))
         (list* 'cond (nreverse clauses)))))

(defmacro ecase (expr &rest cases)
  "(ecase EXPR . CASES) => like `case', but error if no case fits.
`t'-clauses are not allowed."
  (let* ((newsym (gentemp))
         (clauses (case-clausify cases newsym)))
    ;; check that no 't clause is present.
    ;; case-clausify would put one such at the beginning of clauses
    (if (eq (caar clauses) t)
        (error "No clause-head should be `t' or `otherwise' for `ecase'"))
    ;; insert error-catching clause
    (setq clauses
          (cons
           (list 't (list 'error
                          "ecase on %s = %s failed to take any branch."
                          (list 'quote expr)
                          (list 'prin1-to-string newsym)))
           clauses))
    ;; generate code as usual
    (list 'let
          (list (list newsym expr))
          (list* 'cond (nreverse clauses)))))


(defun case-clausify (cases newsym)
  "CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond'
Converts the CASES of a [e]case macro into cond clauses to be
evaluated inside a let that binds NEWSYM.  Returns the clauses in
reverse order."
  (do* ((currentpos cases        (cdr currentpos))
        (nextpos    (cdr cases)  (cdr nextpos))
        (curclause  (car cases)  (car currentpos))
        (result     '()))
      ((endp currentpos) result)
    (let ((head (car curclause))
          (body (cdr curclause)))
      ;; construct a cond-clause according to the head
      (cond
       ((null head)
        (error "Case clauses cannot have null heads: `%s'"
               (prin1-to-string curclause)))
       ((or (eq head 't)
            (eq head 'otherwise))
        ;; check it is the last clause
        (if (not (endp nextpos))
            (error "Clause with `t' or `otherwise' head must be last"))
        ;; accept this clause as a 't' for cond
        (setq result (cons (cons 't body) result)))
       ((atom head)
        (setq result
              (cons (cons (list 'eql newsym (list 'quote head)) body)
                    result)))
       ((listp head)
        (setq result
              (cons (cons (list 'member newsym (list 'quote head)) body)
                    result)))
       (t
        ;; catch-all for this parser
        (error "Don't know how to parse case clause `%s'."
               (prin1-to-string head)))))))

;;;; end of cl-conditionals.el

;;;; ITERATIONS
;;;;    This file provides simple iterative macros (a la Common Lisp)
;;;;    constructed on the basis of let, let* and while, which are the
;;;;    primitive binding/iteration constructs of Emacs Lisp
;;;;
;;;;    The Common Lisp iterations use to have a block named nil
;;;;    wrapped around them, and allow declarations at the beginning
;;;;    of their bodies and you can return a value using (return ...).
;;;;    Nothing of the sort exists in Emacs Lisp, so I haven't tried
;;;;    to imitate these behaviors.
;;;;
;;;;    Other than the above, the semantics of Common Lisp are
;;;;    correctly reproduced to the extent this was reasonable.
;;;;
;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;;       ([e-mail])

;;; some lisp-indentation information
(put 'do                'lisp-indent-hook 2)
(put 'do*               'lisp-indent-hook 2)
(put 'dolist            'lisp-indent-hook 1)
(put 'dotimes           'lisp-indent-hook 1)
(put 'do-symbols        'lisp-indent-hook 1)
(put 'do-all-symbols    'lisp-indent-hook 1)


(defmacro do (stepforms endforms &rest body)
  "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local variables.
STEPFORMS must be a list of symbols or lists.  In the second case, the
lists must start with a symbol and contain up to two more forms. In
the STEPFORMS, a symbol is the same as a (symbol).  The other 2 forms
are the initial value (def. NIL) and the form to step (def. itself).
The values used by initialization and stepping are computed in parallel.
The ENDFORMS are a list (CONDITION . ENDBODY).  If the CONDITION
evaluates to true in any iteration, ENDBODY is evaluated and the last
form in it is returned.
The BODY (which may be empty) is evaluated at every iteration, with
the symbols of the STEPFORMS bound to the initial or stepped values."
  ;; check the syntax of the macro
  (and (check-do-stepforms stepforms)
       (check-do-endforms endforms))
  ;; construct emacs-lisp equivalent
  (let ((initlist (extract-do-inits stepforms))
        (steplist (extract-do-steps stepforms))
        (endcond  (car endforms))
        (endbody  (cdr endforms)))
    (cons 'let (cons initlist
                     (cons (cons 'while (cons (list 'not endcond) 
                                              (append body steplist)))
                           (append endbody))))))


(defmacro do* (stepforms endforms &rest body)
  "`do*' is to `do' as `let*' is to `let'.
STEPFORMS must be a list of symbols or lists.  In the second case, the
lists must start with a symbol and contain up to two more forms. In
the STEPFORMS, a symbol is the same as a (symbol).  The other 2 forms
are the initial value (def. NIL) and the form to step (def. itself).
Initializations and steppings are done in the sequence they are written.
The ENDFORMS are a list (CONDITION . ENDBODY).  If the CONDITION
evaluates to true in any iteration, ENDBODY is evaluated and the last
form in it is returned.
The BODY (which may be empty) is evaluated at every iteration, with
the symbols of the STEPFORMS bound to the initial or stepped values."
  ;; check the syntax of the macro
  (and (check-do-stepforms stepforms)
       (check-do-endforms endforms))
  ;; construct emacs-lisp equivalent
  (let ((initlist (extract-do-inits stepforms))
        (steplist (extract-do*-steps stepforms))
        (endcond  (car endforms))
        (endbody  (cdr endforms)))
    (cons 'let* (cons initlist
                     (cons (cons 'while (cons (list 'not endcond) 
                                              (append body steplist)))
                           (append endbody))))))


;;; DO and DO* share the syntax checking functions that follow.

(defun check-do-stepforms (forms)
  "True if FORMS is a valid stepforms for the do[*] macro (q.v.)"
  (cond
   ((nlistp forms)
    (error "Init/Step form for do[*] should be a list, not `%s'"
           (prin1-to-string forms)))
   (t                                   ;valid list
    ;; each entry must be a symbol, or a list whose car is a symbol
    ;; and whose length is no more than three
    (mapcar
     (function
      (lambda (entry)
        (cond
         ((or (symbolp entry)
              (and (listp entry)
                   (symbolp (car entry))
                   (< (length entry) 4)))
          t)
         (t
          (error
           "Init/Step must be symbol or (symbol [init [step]]), not `%s'"
           (prin1-to-string entry))))))
     forms))))

(defun check-do-endforms (forms)
  "True if FORMS is a valid endforms for the do[*] macro (q.v.)"
  (cond
   ((listp forms)
    t)
   (t
    (error "Termination form for do macro should be a list, not `%s'"
           (prin1-to-string forms)))))

(defun extract-do-inits (forms)
  "Returns a list of the initializations (for do) in FORMS
-a stepforms, see the do macro-. Forms is assumed syntactically valid."
  (mapcar
   (function
    (lambda (entry)
      (cond
       ((symbolp entry)
        (list entry nil))
       ((listp entry)
        (list (car entry) (cadr entry))))))
   forms))

;;; There used to be a reason to deal with DO differently than with
;;; DO*.  The writing of PSETQ has made it largely unnecessary.

(defun extract-do-steps (forms)
  "EXTRACT-DO-STEPS FORMS => an s-expr
FORMS is the stepforms part of a DO macro (q.v.).  This function
constructs an s-expression that does the stepping at the end of an
iteration."
  (list (cons 'psetq (select-stepping-forms forms))))

(defun extract-do*-steps (forms)
  "EXTRACT-DO*-STEPS FORMS => an s-expr
FORMS is the stepforms part of a DO* macro (q.v.).  This function
constructs an s-expression that does the stepping at the end of an
iteration."
  (list (cons 'setq (select-stepping-forms forms))))

(defun select-stepping-forms (forms)
  "Separate only the forms that cause stepping."
  (let ((result '())			;ends up being (... var form ...)
	(ptr forms)			;to traverse the forms
	entry				;to explore each form in turn
	)
    (while ptr				;(not (endp entry)) might be safer
      (setq entry (car ptr))
      (cond
       ((and (listp entry)
	     (= (length entry) 3))
	(setq result (append		;append in reverse order!
		      (list (caddr entry) (car entry))
		      result))))
      (setq ptr (cdr ptr)))		;step in the list of forms
    ;;put things back in the
    ;;correct order before return
    (nreverse result)))

;;; Other iterative constructs

(defmacro dolist  (stepform &rest body)
  "(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST.
The RESULTFORM defaults to nil.  The VAR is bound to successive
elements of the value of LIST and remains bound (to the nil value) when the
RESULTFORM is evaluated."
  ;; check sanity
  (cond
   ((nlistp stepform)
    (error "Stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'"
           (prin1-to-string stepform)))
   ((not (symbolp (car stepform)))
    (error "First component of stepform should be a symbol, not `%s'"
           (prin1-to-string (car stepform))))
   ((> (length stepform) 3)
    (error "Too many components in stepform `%s'"
           (prin1-to-string stepform))))
  ;; generate code
  (let* ((var (car stepform))
         (listform (cadr stepform))
         (resultform (caddr stepform)))
    (list 'progn
          (list 'mapcar
                (list 'function
                      (cons 'lambda (cons (list var) body)))
                listform)
          (list 'let
                (list (list var nil))
                resultform))))

(defmacro dotimes (stepform &rest body)
  "(dotimes (VAR COUNTFORM [RESULTFORM]) .  BODY): Repeat BODY, counting in VAR.
The COUNTFORM should return a positive integer.  The VAR is bound to
successive integers from 0 to COUNTFORM-1 and the BODY is repeated for
each of them.  At the end, the RESULTFORM is evaluated and its value
returned. During this last evaluation, the VAR is still bound, and its
value is the number of times the iteration occurred. An omitted RESULTFORM
defaults to nil."
  ;; check sanity 
  (cond
   ((nlistp stepform)
    (error "Stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'"
           (prin1-to-string stepform)))
   ((not (symbolp (car stepform)))
    (error "First component of stepform should be a symbol, not `%s'"
           (prin1-to-string (car stepform))))
   ((> (length stepform) 3)
    (error "Too many components in stepform `%s'"
           (prin1-to-string stepform))))
  ;; generate code
  (let* ((var (car stepform))
         (countform (cadr stepform))
         (resultform (caddr stepform))
         (newsym (gentemp)))
    (list
     'let* (list (list newsym countform))
     (list*
      'do*
      (list (list var 0 (list '+ var 1)))
      (list (list '>= var newsym) resultform)
      body))))

(defmacro do-symbols (stepform &rest body)
  "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY)
The VAR is bound to each of the symbols in OBARRAY (def. obarray) and
the BODY is repeatedly performed for each of those bindings. At the
end, RESULTFORM (def. nil) is evaluated and its value returned.
During this last evaluation, the VAR is still bound and its value is nil.
See also the function `mapatoms'."
  ;; check sanity
  (cond
   ((nlistp stepform)
    (error "Stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'"
           (prin1-to-string stepform)))
   ((not (symbolp (car stepform)))
    (error "First component of stepform should be a symbol, not `%s'"
           (prin1-to-string (car stepform))))
   ((> (length stepform) 3)
    (error "Too many components in stepform `%s'"
           (prin1-to-string stepform))))
  ;; generate code
  (let* ((var (car stepform))
         (oblist (cadr stepform))
         (resultform (caddr stepform)))
    (list 'progn
          (list 'mapatoms
                (list 'function
                      (cons 'lambda (cons (list var) body)))
                oblist)
          (list 'let
                (list (list var nil))
                resultform))))


(defmacro do-all-symbols (stepform &rest body)
  "(do-all-symbols (VAR [RESULTFORM]) . BODY)
Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)."
  (list*
   'do-symbols
   (list (car stepform) 'obarray (cadr stepform))
   body))

(defmacro loop (&rest body)
  "(loop . BODY) repeats BODY indefinitely and does not return.
Normally BODY uses `throw' or `signal' to cause an exit.
The forms in BODY should be lists, as non-lists are reserved for new features."
  ;; check that the body doesn't have atomic forms
  (if (nlistp body)
      (error "Body of `loop' should be a list of lists or nil")
    ;; ok, it is a list, check for atomic components
    (mapcar