cl.el

早期freebsd实现

;; Common-Lisp extensions for GNU Emacs Lisp.
;; Copyright (C) 1987, 1988 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;;;
;;;; These are extensions to Emacs Lisp that provide some form of
;;;; Common Lisp compatibility, beyond what is already built-in
;;;; in Emacs Lisp.
;;;;
;;;; When developing them, I had the code spread among several files.
;;;; This file 'cl.el' is a concatenation of those original files,
;;;; minus some declarations that became redundant.  The marks between
;;;; the original files can be found easily, as they are lines that
;;;; begin with four semicolons (as this does).  The names of the
;;;; original parts follow the four semicolons in uppercase, those
;;;; names are GLOBAL, SYMBOLS, LISTS, SEQUENCES, CONDITIONALS,
;;;; ITERATIONS, MULTIPLE VALUES, ARITH, SETF and DEFSTRUCT.  If you
;;;; add functions to this file, you might want to put them in a place
;;;; that is compatible with the division above (or invent your own
;;;; categories).
;;;;
;;;; To compile this file, make sure you load it first.  This is
;;;; because many things are implemented as macros and now that all
;;;; the files are concatenated together one cannot ensure that
;;;; declaration always precedes use.
;;;;
;;;; Bug reports, suggestions and comments,
;;;; to [e-mail]

(provide 'cl)


;;;; GLOBAL
;;;;    This file provides utilities and declarations that are global
;;;;    to Common Lisp and so might be used by more than one of the
;;;;    other libraries.  Especially, I intend to keep here some
;;;;    utilities that help parsing/destructuring some difficult calls. 
;;;;
;;;;
;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;;       ([e-mail])

(defmacro psetq (&rest pairs)
  "(psetq {VARIABLE VALUE}...): In parallel, set each VARIABLE to its VALUE.
All the VALUEs are evaluated, and then all the VARIABLEs are set.
Aside from order of evaluation, this is the same as `setq'."
  (let ((nforms (length pairs))		;count of args
	;; next are used to destructure the call
	symbols				;even numbered args
	forms				;odd numbered args
	;; these are used to generate code
	bindings			;for the let
	newsyms				;list of gensyms
	assignments			;for the setq
	;; auxiliary indices
	i)
    ;; check there is a reasonable number of forms
    (if (/= (% nforms 2) 0)
	(error "Odd number of arguments to `psetq'"))

    ;; destructure the args
    (let ((ptr pairs)			;traverses the args
	  var				;visits each symbol position
	  )
      (while ptr
	(setq var (car ptr))		;next variable
	(if (not (symbolp var))
	    (error "`psetq' expected a symbol, found '%s'."
		   (prin1-to-string var)))
	(setq symbols (cons var symbols))
	(setq forms   (cons (car (cdr ptr)) forms))
	(setq ptr (cdr (cdr ptr)))))

    ;; assign new symbols to the bindings
    (let ((ptr forms)			;traverses the forms
	  form				;each form goes here
	  newsym			;gensym for current value of form
	  )
      (while ptr
	(setq form (car ptr))
	(setq newsym (gensym))
	(setq bindings (cons (list newsym form) bindings))
	(setq newsyms (cons newsym newsyms))
	(setq ptr (cdr ptr))))
    (setq newsyms (nreverse newsyms))	;to sync with symbols
    
    ;; pair symbols with newsyms for assignment
    (let ((ptr1 symbols)		;traverses original names
	  (ptr2 newsyms)		;traverses new symbols
	  )
      (while ptr1
	(setq assignments
	      (cons (car ptr1) (cons (car ptr2) assignments)))
	(setq ptr1 (cdr ptr1))
	(setq ptr2 (cdr ptr2))))
    
    ;; generate code
    (list 'let
	  bindings
	  (cons 'setq assignments)
	  nil)))

;;; utilities
;;;
;;; pair-with-newsyms takes a list and returns a list of lists of the
;;; form (newsym form), such that a let* can then bind the evaluation
;;; of the forms to the newsyms.  The idea is to guarantee correct
;;; order of evaluation of the subforms of a setf.  It also returns a
;;; list of the newsyms generated, in the corresponding order.

(defun pair-with-newsyms (oldforms)
  "PAIR-WITH-NEWSYMS OLDFORMS
The top-level components of the list oldforms are paired with fresh
symbols, the pairings list and the newsyms list are returned."
  (do ((ptr oldforms (cdr ptr))
       (bindings '())
       (newsyms  '()))
      ((endp ptr) (values (nreverse bindings) (nreverse newsyms)))
    (let ((newsym (gentemp)))
      (setq bindings (cons (list newsym (car ptr)) bindings))
      (setq newsyms  (cons newsym newsyms)))))

(defun zip-lists (evens odds)
  "Merge two lists EVENS and ODDS, taking elts from each list alternatingly.
EVENS and ODDS are two lists.  ZIP-LISTS constructs a new list, whose
even numbered elements (0,2,...) come from EVENS and whose odd
numbered elements (1,3,...) come from ODDS. 
The construction stops when the shorter list is exhausted."
  (do* ((p0   evens    (cdr p0))
        (p1   odds     (cdr p1))
        (even (car p0) (car p0))
        (odd  (car p1) (car p1))
        (result '()))
      ((or (endp p0) (endp p1))
       (nreverse result))
    (setq result
          (cons odd (cons even result)))))

(defun unzip-list (list)
  "Extract even and odd elements of LIST into two separate lists.
The argument LIST is separated in two strands, the even and the odd
numbered elements.  Numbering starts with 0, so the first element
belongs in EVENS. No check is made that there is an even number of
elements to start with."
  (do* ((ptr   list       (cddr ptr))
        (this  (car ptr)  (car ptr))
        (next  (cadr ptr) (cadr ptr))
        (evens '())
        (odds  '()))
      ((endp ptr)
       (values (nreverse evens) (nreverse odds)))
    (setq evens (cons this evens))
    (setq odds  (cons next odds))))

(defun reassemble-argslists (argslists)
  "(reassemble-argslists ARGSLISTS).
ARGSLISTS is a list of sequences.  Return a list of lists, the first
sublist being all the entries coming from ELT 0 of the original
sublists, the next those coming from ELT 1 and so on, until the
shortest list is exhausted."
  (let* ((minlen   (apply 'min (mapcar 'length argslists)))
         (result   '()))
    (dotimes (i minlen (nreverse result))
      ;; capture all the elements at index i
      (setq result
            (cons (mapcar
                   (function (lambda (sublist) (elt sublist i)))
                   argslists)
                  result)))))

;;; to help parsing keyword arguments

(defun build-klist (argslist acceptable)
  "Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE.
ARGSLIST is a list, presumably the &rest argument of a call, whose
even numbered elements must be keywords.
ACCEPTABLE is a list of keywords, the only ones that are truly acceptable.
The result is an alist containing the arguments named by the keywords
in ACCEPTABLE, or nil if something failed."

  ;; check legality of the arguments, then destructure them
  (unless (and (listp argslist)
               (evenp (length argslist)))
    (error "Odd number of keyword-args"))
  (unless (and (listp acceptable)
               (every 'keywordp acceptable))
    (error "Second arg should be a list of keywords"))
  (multiple-value-bind
      (keywords forms)
      (unzip-list argslist)
    (unless (every 'keywordp keywords)
      (error "Expected keywords, found `%s'"
             (prin1-to-string keywords)))
    (do*                                ;pick up the pieces
        ((auxlist                       ;auxiliary a-list, may
          (pairlis keywords forms))     ;contain repetitions and junk
         (ptr    acceptable  (cdr ptr)) ;pointer in acceptable
         (this  (car ptr)  (car ptr))   ;current acceptable keyword
         (auxval nil)                   ;used to move values around
         (alist  '()))                  ;used to build the result
        ((endp ptr) alist)
      ;; if THIS appears in auxlist, use its value
      (when (setq auxval (assoc this auxlist))
        (setq alist (cons auxval alist))))))


;;; Checking that a list of symbols contains no duplicates is a common
;;; task when checking the legality of some macros.  The check for 'eq
;;; pairs can be too expensive, as it is quadratic on the length of
;;; the list.  I use a 4-pass, linear, counting approach.  It surely
;;; loses on small lists (less than 5 elements?), but should win for
;;; larger lists.  The fourth pass could be eliminated.
;;; 10 dec 1986.  Emacs Lisp has no REMPROP, so I just eliminated the
;;; 4th pass.
(defun duplicate-symbols-p (list)
  "Find all symbols appearing more than once in LIST.
Return a list of all such duplicates; `nil' if there are no duplicates."
  (let  ((duplicates '())               ;result built here
         (propname   (gensym))          ;we use a fresh property
         )
    ;; check validity
    (unless (and (listp list)
                 (every 'symbolp list))
      (error "A list of symbols is needed"))
    ;; pass 1: mark
    (dolist (x list)
      (put x propname 0))
    ;; pass 2: count
    (dolist (x list)
      (put x propname (1+ (get x propname))))
    ;; pass 3: collect
    (dolist (x list)
      (if (> (get x propname) 1)
          (setq duplicates (cons x duplicates))))
    ;; pass 4: unmark.  eliminated.
    ;; (dolist (x list) (remprop x propname))
    ;; return result
    duplicates))

;;;; end of cl-global.el

;;;; SYMBOLS
;;;;    This file provides the gentemp function, which generates fresh
;;;;    symbols, plus some other minor Common Lisp symbol tools.
;;;;
;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;;       ([e-mail])

;;; Keywords.  There are no packages in Emacs Lisp, so this is only a
;;; kludge around to let things be "as if" a keyword package was around.

(defmacro defkeyword (x &optional docstring)
  "Make symbol X a keyword (symbol whose value is itself).
Optional second argument is a documentation string for it."
  (cond
   ((symbolp x)
    (list 'defconst x (list 'quote x)))
   (t
    (error "`%s' is not a symbol" (prin1-to-string x)))))

(defun keywordp (sym)
  "Return `t' if SYM is a keyword."
  (cond
   ((and (symbolp sym)
         (char-equal (aref (symbol-name sym) 0) ?\:))
    ;; looks like one, make sure value is right
    (set sym sym))
   (t
    nil)))

(defun keyword-of (sym)
  "Return a keyword that is naturally associated with symbol SYM.
If SYM is keyword, the value is SYM.
Otherwise it is a keyword whose name is `:' followed by SYM's name."
  (cond
   ((keywordp sym)
    sym)
   ((symbolp sym)
    (let ((newsym (intern (concat ":" (symbol-name sym)))))
      (set newsym newsym)))
   (t
    (error "Expected a symbol, not `%s'" (prin1-to-string sym)))))

;;; Temporary symbols.  
;;; 

(defvar *gentemp-index* 0
  "Integer used by gentemp to produce new names.")

(defvar *gentemp-prefix* "T$$_"
  "Names generated by gentemp begin with this string by default.")

(defun gentemp (&optional prefix oblist)
  "Generate a fresh interned symbol.
There are 2 optional arguments, PREFIX and OBLIST.  PREFIX is the
string that begins the new name, OBLIST is the obarray used to search for
old names.  The defaults are just right, YOU SHOULD NEVER NEED THESE
ARGUMENTS IN YOUR OWN CODE."
  (if (null prefix)
      (setq prefix *gentemp-prefix*))
  (if (null oblist)
      (setq oblist obarray))            ;default for the intern functions
  (let ((newsymbol nil)
        (newname))
    (while (not newsymbol)
      (setq newname (concat prefix *gentemp-index*))
      (setq *gentemp-index* (+ *gentemp-index* 1))
      (if (not (intern-soft newname oblist))
          (setq newsymbol (intern newname oblist))))
    newsymbol))

(defvar *gensym-index* 0
  "Integer used by gensym to produce new names.")

(defvar *gensym-prefix* "G$$_"
  "Names generated by gensym begin with this string by default.")

(defun gensym (&optional prefix)
  "Generate a fresh uninterned symbol.
There is an  optional argument, PREFIX.  PREFIX is the
string that begins the new name. Most people take just the default,
except when debugging needs suggest otherwise."
  (if (null prefix)
      (setq prefix *gensym-prefix*))
  (let ((newsymbol nil)
        (newname   ""))
    (while (not newsymbol)
      (setq newname (concat prefix *gensym-index*))
      (setq *gensym-index* (+ *gensym-index* 1))
      (if (not (intern-soft newname))
          (setq newsymbol (make-symbol newname))))
    newsymbol))

;;;; end of cl-symbols.el

;;;; CONDITIONALS
;;;;    This file provides some of the conditional constructs of
;;;;    Common Lisp.  Total compatibility is again impossible, as the
;;;;    'if' form is different in both languages, so only a good
;;;;    approximation is desired.
;;;;
;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;;       ([e-mail])

;;; indentation info
(put 'case      'lisp-indent-hook 1)
(put 'ecase     'lisp-indent-hook 1)
(put 'when      'lisp-indent-hook 1)
(put 'unless    'lisp-indent-hook 1)

;;; WHEN and UNLESS
;;; These two forms are simplified ifs, with a single branch.