(tempo-local-tags, tempo-user-elements, tempo-use-tag-list):

[gnu-emacs] / lisp / cl.el

diff --git a/lisp/cl.el b/lisp/cl.el
index b675d926fb85552964cf0aeccc6f0ab68f7e129f..1a6a385e3eec815ef10e644a9559cd95e7a22262 100644 (file)
--- a/lisp/cl.el
+++ b/lisp/cl.el
@@ -1,11 +1,11 @@
 ;;; cl.el --- Common-Lisp extensions for GNU Emacs Lisp.
 
 ;;; cl.el --- Common-Lisp extensions for GNU Emacs Lisp.
 

-;; Copyright (C) 1987, 1988, 1989 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1988, 1989, 1992  Free Software Foundation, Inc.

 
 ;; Author: Cesar Quiroz <quiroz@cs.rochester.edu>
 ;; Keywords: extensions
 
 
 ;; Author: Cesar Quiroz <quiroz@cs.rochester.edu>
 ;; Keywords: extensions
 

-(defvar cl-version "2.0 beta 29 October 1989")
+(defvar cl-version "3.0        07-February-1993")

 
 ;; This file is part of GNU Emacs.
 
 
 ;; This file is part of GNU Emacs.
 


@@ -26,6 +26,29 @@
 
 ;;; Commentary:
 
 
 ;;; Commentary:
 

+;;; Notes from Rob Austein on his mods
+;; yaya:/usr/u/sra/cl/cl.el, 5-May-1991 16:01:34, sra
+;;
+;; Slightly hacked copy of cl.el 2.0 beta 27.
+;;
+;; Various minor performance improvements:
+;;  a) Don't use MAPCAR when we're going to discard its results.
+;;  b) Make various macros a little more clever about optimizing
+;;     generated code in common cases.
+;;  c) Fix DEFSETF to expand to the right code at compile-time.
+;;  d) Make various macros cleverer about generating reasonable
+;;     code when compiled, particularly forms like DEFSTRUCT which
+;;     are usually used at top-level and thus are only compiled if
+;;     you use Hallvard Furuseth's hacked bytecomp.el.
+;;
+;; New features: GETF, REMF, and REMPROP.
+;;
+;; Notes:
+;;  1) I'm sceptical about the FBOUNDP checks in SETF.  Why should
+;;     the SETF expansion fail because the SETF method isn't defined
+;;     at compile time?  Lisp is going to check for a binding at run-time
+;;     anyway, so maybe we should just assume the user's right here.
+

 ;;;; These are extensions to Emacs Lisp that provide some form of
 ;;;; Common Lisp compatibility, beyond what is already built-in
 ;;;; in Emacs Lisp.
 ;;;; These are extensions to Emacs Lisp that provide some form of
 ;;;; Common Lisp compatibility, beyond what is already built-in
 ;;;; in Emacs Lisp.


@@ -47,6 +70,9 @@
 ;;;; the files are concatenated together one cannot ensure that
 ;;;; declaration always precedes use.
 ;;;;
 ;;;; the files are concatenated together one cannot ensure that
 ;;;; declaration always precedes use.
 ;;;;

+;;;; Bug reports, suggestions and comments,
+;;;; to quiroz@cs.rochester.edu
+

 \f
 ;;;; GLOBAL
 ;;;;    This file provides utilities and declarations that are global
 \f
 ;;;; GLOBAL
 ;;;;    This file provides utilities and declarations that are global


@@ -64,29 +90,23 @@
 
 ;;; Code:
 
 
 ;;; Code:
 

-(defmacro psetq (&rest body)
-  "(psetq {var value }...) => nil
-Like setq, but all the values are computed before any assignment is made."
-  (let ((length (length body)))
-    (cond ((/= (% length 2) 0)
-           (error "psetq needs an even number of arguments, %d given"
-                  length))
-          ((null body)
-           '())
-          (t
-           (list 'prog1 nil
-                 (let ((setqs     '())
-                       (bodyforms (reverse body)))
-                   (while bodyforms
-                     (let* ((value (car bodyforms))
-                            (place (cadr bodyforms)))
-                       (setq bodyforms (cddr bodyforms))
-                       (if (null setqs)
-                           (setq setqs (list 'setq place value))
-                         (setq setqs (list 'setq place
-                                           (list 'prog1 value
-                                                 setqs))))))
-                   setqs))))))
+;;; This version is due to Hallvard Furuseth (hallvard@ifi.uio.no, 6 Jul 91)
+(defmacro psetq (&rest args)
+  "(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'."
+  ;; check there is a reasonable number of forms
+  (if (/= (% (length args) 2) 0)
+      (error "Odd number of arguments to `psetq'"))
+  (setq args (copy-sequence args))      ;for safety below
+  (prog1 (cons 'setq args)
+    (while (progn (if (not (symbolp (car args)))
+                     (error "`psetq' expected a symbol, found '%s'."
+                            (prin1-to-string (car args))))
+                 (cdr (cdr args)))
+      (setcdr args (list (list 'prog1 (nth 1 args)
+                              (cons 'setq
+                                    (setq args (cdr (cdr args))))))))))

 \f
 ;;; utilities
 ;;;
 \f
 ;;; utilities
 ;;;


@@ -111,8 +131,8 @@ symbols, the pairings list and the newsyms list are returned."
 (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
 (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.
+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))
 The construction stops when the shorter list is exhausted."
   (do* ((p0   evens    (cdr p0))
         (p1   odds     (cdr p1))


@@ -164,9 +184,11 @@ shortest list is exhausted."
 ;;; larger lists.  The fourth pass could be eliminated.
 ;;; 10 dec 1986.  Emacs Lisp has no REMPROP, so I just eliminated the
 ;;; 4th pass.
 ;;; larger lists.  The fourth pass could be eliminated.
 ;;; 10 dec 1986.  Emacs Lisp has no REMPROP, so I just eliminated the
 ;;; 4th pass.

+;;;
+;;; [22 April 1991, sra] REMPROP now in library, so restored 4th pass.

 (defun duplicate-symbols-p (list)
   "Find all symbols appearing more than once in LIST.
 (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."
+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
          )
   (let  ((duplicates '())               ;result built here
          (propname   (gensym))          ;we use a fresh property
          )


@@ -184,8 +206,9 @@ Return a list of all such duplicates; nil if there are no duplicates."
     (dolist (x list)
       (if (> (get x propname) 1)
           (setq duplicates (cons x duplicates))))
     (dolist (x list)
       (if (> (get x propname) 1)
           (setq duplicates (cons x duplicates))))

-    ;; pass 4: unmark.  eliminated.
-    ;; (dolist (x list) (remprop x propname))
+    ;; pass 4: unmark.
+    (dolist (x list)
+      (remprop x propname))

     ;; return result
     duplicates))
 
     ;; return result
     duplicates))
 


@@ -203,14 +226,14 @@ Return a list of all such duplicates; nil if there are no duplicates."
 
 (defmacro defkeyword (x &optional docstring)
   "Make symbol X a keyword (symbol whose value is itself).
 
 (defmacro defkeyword (x &optional docstring)
   "Make symbol X a keyword (symbol whose value is itself).

-Optional second arg DOCSTRING is a documentation string for it."
+Optional second argument is a documentation string for it."

   (cond ((symbolp x)
          (list 'defconst x (list 'quote x) docstring))
         (t
          (error "`%s' is not a symbol" (prin1-to-string x)))))
 
 (defun keywordp (sym)
   (cond ((symbolp x)
          (list 'defconst x (list 'quote x) docstring))
         (t
          (error "`%s' is not a symbol" (prin1-to-string x)))))
 
 (defun keywordp (sym)

-  "Return t if SYM is a keyword."
+  "t if SYM is a keyword."

   (if (and (symbolp sym) (char-equal (aref (symbol-name sym) 0) ?\:))
       ;; looks like one, make sure value is right
       (set sym sym)
   (if (and (symbolp sym) (char-equal (aref (symbol-name sym) 0) ?\:))
       ;; looks like one, make sure value is right
       (set sym sym)


@@ -232,17 +255,17 @@ Otherwise it is a keyword whose name is `:' followed by SYM's name."
 ;;; 
 
 (defvar *gentemp-index* 0
 ;;; 
 
 (defvar *gentemp-index* 0

-  "Integer used by `gentemp' to produce new names.")
+  "Integer used by gentemp to produce new names.")

 
 (defvar *gentemp-prefix* "T$$_"
 
 (defvar *gentemp-prefix* "T$$_"

-  "Names generated by `gentemp begin' with this string by default.")
+  "Names generated by gentemp begin with this string by default.")

 
 (defun gentemp (&optional prefix oblist)
   "Generate a fresh interned symbol.
 
 (defun gentemp (&optional prefix oblist)
   "Generate a fresh interned symbol.

-There are two 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."
+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)
   (if (null prefix)
       (setq prefix *gentemp-prefix*))
   (if (null oblist)


@@ -257,15 +280,16 @@ IN YOUR OWN CODE."
     newsymbol))
 \f
 (defvar *gensym-index* 0
     newsymbol))
 \f
 (defvar *gensym-index* 0

-  "Integer used by `gensym' to produce new names.")
+  "Integer used by gensym to produce new names.")

 
 (defvar *gensym-prefix* "G$$_"
 
 (defvar *gensym-prefix* "G$$_"

-  "Names generated by `gensym' begin with this string by default.")
+  "Names generated by gensym begin with this string by default.")

 
 (defun gensym (&optional prefix)
   "Generate a fresh uninterned symbol.
 
 (defun gensym (&optional prefix)
   "Generate a fresh uninterned symbol.

-Optional arg PREFIX is the string that begins the new name.  Most people
-take just the default, except when debugging needs suggest otherwise."
+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)
   (if (null prefix)
       (setq prefix *gensym-prefix*))
   (let ((newsymbol nil)


@@ -289,10 +313,10 @@ take just the default, except when debugging needs suggest otherwise."
 ;;;;       (quiroz@cs.rochester.edu)
 
 ;;; indentation info
 ;;;;       (quiroz@cs.rochester.edu)
 
 ;;; indentation info

-(put 'case      'lisp-indent-function 1)
-(put 'ecase     'lisp-indent-function 1)
-(put 'when      'lisp-indent-function 1)
-(put 'unless    'lisp-indent-function 1)
+(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.
 
 ;;; WHEN and UNLESS
 ;;; These two forms are simplified ifs, with a single branch.


@@ -408,29 +432,26 @@ reverse order."
 ;;;;       (quiroz@cs.rochester.edu)
 
 ;;; some lisp-indentation information
 ;;;;       (quiroz@cs.rochester.edu)
 
 ;;; some lisp-indentation information

-(put 'do                'lisp-indent-function 2)
-(put 'do*               'lisp-indent-function 2)
-(put 'dolist            'lisp-indent-function 1)
-(put 'dotimes           'lisp-indent-function 1)
-(put 'do-symbols        'lisp-indent-function 1)
-(put 'do-all-symbols    'lisp-indent-function 1)
+(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)

 
 \f
 (defmacro do (stepforms endforms &rest body)
 
 \f
 (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 two forms
+  "(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).
 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 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."
-
+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))
   ;; check the syntax of the macro
   (and (check-do-stepforms stepforms)
        (check-do-endforms endforms))


@@ -448,16 +469,13 @@ symbols of the STEPFORMS bound to the initial or stepped values."
 (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
 (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 two forms are
-the initial value (def. NIL) and the form to step (def. itself).
-
+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.
 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 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
 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


@@ -501,8 +519,7 @@ the symbols of the STEPFORMS bound to the initial or stepped values."
 
 (defun extract-do-inits (forms)
   "Returns a list of the initializations (for do) in 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."
+--a stepforms, see the do macro--. FORMS is assumed syntactically valid."

   (mapcar
    (function
     (lambda (entry)
   (mapcar
    (function
     (lambda (entry)


@@ -516,15 +533,17 @@ FORMS is assumed syntactically valid."
 ;;; DO*.  The writing of PSETQ has made it largely unnecessary.
 
 (defun extract-do-steps (forms)
 ;;; 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."
+  "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)
   (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."
+  "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)
   (list (cons 'setq (select-stepping-forms forms))))
 
 (defun select-stepping-forms (forms)


@@ -546,8 +565,8 @@ an s-expression that does the stepping at the end of an iteration."
 
 (defmacro dolist  (stepform &rest body)
   "(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST.
 
 (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
+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
 RESULTFORM is evaluated."
   ;; check sanity
   (cond


@@ -563,23 +582,27 @@ RESULTFORM is evaluated."
   ;; generate code
   (let* ((var (car stepform))
          (listform (cadr 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))))
+         (resultform (caddr stepform))
+        (listsym (gentemp)))
+    (nconc
+     (list 'let (list var (list listsym listform))
+          (nconc
+           (list 'while listsym
+                 (list 'setq
+                       var (list 'car listsym)
+                       listsym (list 'cdr listsym)))
+           body))
+     (and resultform
+         (cons (list 'setq var nil)
+               (list resultform))))))

 
 (defmacro dotimes (stepform &rest body)
 
 (defmacro dotimes (stepform &rest body)

-  "(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR.
+  "(dotimes (VAR COUNTFORM [RESULTFORM]) .  BODY): Repeat BODY, counting in VAR.

 The COUNTFORM should return a positive integer.  The VAR is bound to
 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
+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
 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
+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
 defaults to nil."
   ;; check sanity 
   (cond


@@ -596,14 +619,16 @@ defaults to nil."
   (let* ((var (car stepform))
          (countform (cadr stepform))
          (resultform (caddr stepform))
   (let* ((var (car stepform))
          (countform (cadr stepform))
          (resultform (caddr stepform))

-         (newsym (gentemp)))
+         (testsym (if (consp countform) (gentemp) countform)))
+    (nconc

     (list
     (list

-     'let* (list (list newsym countform))
-     (list*
-      'do*
-      (list (list var 0 (list '+ var 1)))
-      (list (list '>= var newsym) resultform)
-      body))))
+      'let (cons (list var -1)
+               (and (not (eq countform testsym))
+                    (list (list testsym countform))))
+      (nconc
+       (list 'while (list '< (list 'setq var (list '1+ var)) testsym))
+       body))
+     (and resultform (list resultform)))))

 \f
 (defmacro do-symbols (stepform &rest body)
   "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY)
 \f
 (defmacro do-symbols (stepform &rest body)
   "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY)


@@ -671,112 +696,52 @@ The forms in BODY should be lists, as non-lists are reserved for new features."
 ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
 ;;;;       (quiroz@cs.rochester.edu)
 
 ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
 ;;;;       (quiroz@cs.rochester.edu)
 

-(defvar *cl-valid-named-list-accessors*
-    '(first rest second third fourth fifth sixth seventh eighth ninth tenth))
-(defvar *cl-valid-nth-offsets*
-    '((second   . 1)
-      (third    . 2)
-      (fourth   . 3)
-      (fifth    . 4)
-      (sixth    . 5)
-      (seventh  . 6)
-      (eighth   . 7)
-      (ninth    . 8)
-      (tenth    . 9)))
-
-(defun byte-compile-named-list-accessors (form)
-  "Generate code for (<accessor> FORM), where <accessor> is one of the named
-list accessors: first, second, ..., tenth, rest."
-  (let* ((fun       (car form))
-         (arg       (cadr form))
-         (valid     *cl-valid-named-list-accessors*)
-         (offsets   *cl-valid-nth-offsets*))
-    (cond
-
-     ;; Check that it's a form we're prepared to handle.
-     ((not (memq fun valid))
-      (error
-       "cl.el internal bug: `%s' not in {first, ..., tenth, rest}"
-       fun))
-
-     ;; Check the number of arguments.
-     ((not (= (length form) 2))
-      (byte-compile-subr-wrong-args form 1))
-
-     ;; If the result will simply be tossed, don't generate any code for
-     ;; it, and indicate that we have already discarded the value.
-     (for-effect
-      (setq for-effect nil))
-
-     ;; Generate code for the call.
-     ((eq fun 'first)
-      (byte-compile-form arg)
-      (byte-compile-out 'byte-car 0))
-     ((eq fun 'rest)
-      (byte-compile-form arg)
-      (byte-compile-out 'byte-cdr 0))
-     (t                                ;one of the others
-      (byte-compile-constant (cdr (assq fun offsets)))
-      (byte-compile-form arg)
-      (byte-compile-out 'byte-nth 0)))))
-

 ;;; Synonyms for list functions
 ;;; Synonyms for list functions

-(defun first (x)
+(defsubst first (x)

   "Synonym for `car'"
   (car x))
   "Synonym for `car'"
   (car x))

-(put 'first 'byte-compile 'byte-compile-named-list-accessors)

 
 

-(defun second (x)
+(defsubst second (x)

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

-(put 'second 'byte-compile 'byte-compile-named-list-accessors)

 
 

-(defun third (x)
+(defsubst third (x)

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

-(put 'third 'byte-compile 'byte-compile-named-list-accessors)

 
 

-(defun fourth (x)
+(defsubst fourth (x)

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

-(put 'fourth 'byte-compile 'byte-compile-named-list-accessors)

 
 

-(defun fifth (x)
+(defsubst fifth (x)

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

-(put 'fifth 'byte-compile 'byte-compile-named-list-accessors)

 
 

-(defun sixth (x)
+(defsubst sixth (x)

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

-(put 'sixth 'byte-compile 'byte-compile-named-list-accessors)

 
 

-(defun seventh (x)
+(defsubst seventh (x)

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

-(put 'seventh 'byte-compile 'byte-compile-named-list-accessors)

 
 

-(defun eighth (x)
+(defsubst eighth (x)

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

-(put 'eighth 'byte-compile 'byte-compile-named-list-accessors)

 
 

-(defun ninth (x)
+(defsubst ninth (x)

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

-(put 'ninth 'byte-compile 'byte-compile-named-list-accessors)

 
 

-(defun tenth (x)
+(defsubst tenth (x)

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

-(put 'tenth 'byte-compile 'byte-compile-named-list-accessors)

 
 

-(defun rest (x)
+(defsubst rest (x)

   "Synonym for `cdr'"
   (cdr x))
   "Synonym for `cdr'"
   (cdr x))

-(put 'rest 'byte-compile 'byte-compile-named-list-accessors)

 \f
 \f

-(defun endp (x)
+(defsubst endp (x)

   "t if X is nil, nil if X is a cons; error otherwise."
   (if (listp x)
       (null x)
   "t if X is nil, nil if X is a cons; error otherwise."
   (if (listp x)
       (null x)


@@ -813,18 +778,20 @@ list accessors: first, second, ..., tenth, rest."
   "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))
   "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))))
+  (nreverse (nthcdr n (reverse list)))) ;optim. due to macrakis@osf.org

 
 

+;;; This version due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91)

 (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
 (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)))
+      (let* ((others (cons arg (copy-sequence others)))
+            (a others))
+       (while (cdr (cdr a))
+         (setq a (cdr a)))
+       (setcdr a (car (cdr a)))
+       others)))

 
 (defun adjoin (item list)
   "Return a list which contains ITEM but is otherwise like LIST.
 
 (defun adjoin (item list)
   "Return a list which contains ITEM but is otherwise like LIST.


@@ -848,205 +815,140 @@ SUBLIST must be one of the links in LIST; otherwise the value is LIST itself."
 ;;; To implement this efficiently, a new byte compile handler is used to
 ;;; generate the minimal code, saving one function call.
 
 ;;; To implement this efficiently, a new byte compile handler is used to
 ;;; generate the minimal code, saving one function call.
 

-(defun byte-compile-ca*d*r (form)
-  "Generate code for a (c[ad]+r argument).  This realizes the various
-combinations of car and cdr whose names are supported in this implementation.
-To use this functionality for a given function,just give its name a
-'byte-compile property of 'byte-compile-ca*d*r"
-  (let* ((fun (car form))
-         (arg (cadr form))
-         (seq (mapcar (function (lambda (letter)
-                                  (if (= letter ?a)
-                                      'byte-car 'byte-cdr)))
-                      (cdr (nreverse (cdr (append (symbol-name fun) nil)))))))
-    ;; SEQ is a list of byte-car and byte-cdr in the correct order.
-    (cond
-
-     ;; Is this a function we can handle?
-     ((null seq)
-      (error
-       "cl.el internal bug: `%s' cannot be compiled by byte-compile-ca*d*r"
-       (prin1-to-string form)))
-
-     ;; Are we passing this function the correct number of arguments?
-     ((or (null (cdr form)) (cddr form))
-      (byte-compile-subr-wrong-args form 1))
-
-     ;; Are we evaluating this expression for effect only?
-     (for-effect
-
-      ;; We needn't generate any actual code, as long as we tell the rest 
-      ;; of the compiler that we didn't push anything on the stack.
-      (setq for-effect nil))
-
-     ;; Generate code for the function.
-     (t
-      (byte-compile-form arg)
-      (while seq
-       (byte-compile-out (car seq) 0)
-       (setq seq (cdr seq)))))))
-
-(defun caar (X)
+(defsubst caar (X)

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

-(put 'caar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cadr (X)
+(defsubst cadr (X)

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

-(put 'cadr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cdar (X)
+(defsubst cdar (X)

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

-(put 'cdar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cddr (X)
+(defsubst cddr (X)

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

-(put 'cddr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun caaar (X)
+(defsubst caaar (X)

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

-(put 'caaar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun caadr (X)
+(defsubst caadr (X)

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

-(put 'caadr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cadar (X)
+(defsubst cadar (X)

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

-(put 'cadar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cdaar (X)
+(defsubst cdaar (X)

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

-(put 'cdaar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun caddr (X)
+(defsubst caddr (X)

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

-(put 'caddr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cdadr (X)
+(defsubst cdadr (X)

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

-(put 'cdadr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cddar (X)
+(defsubst cddar (X)

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

-(put 'cddar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cdddr (X)
+(defsubst cdddr (X)

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

-(put 'cdddr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun caaaar (X)
+(defsubst caaaar (X)

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

-(put 'caaaar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun caaadr (X)
+(defsubst caaadr (X)

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

-(put 'caaadr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun caadar (X)
+(defsubst caadar (X)

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

-(put 'caadar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cadaar (X)
+(defsubst cadaar (X)

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

-(put 'cadaar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cdaaar (X)
+(defsubst cdaaar (X)

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

-(put 'cdaaar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun caaddr (X)
+(defsubst caaddr (X)

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

-(put 'caaddr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cadadr (X)
+(defsubst cadadr (X)

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

-(put 'cadadr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cdaadr (X)
+(defsubst cdaadr (X)

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

-(put 'cdaadr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun caddar (X)
+(defsubst caddar (X)

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

-(put 'caddar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cdadar (X)
+(defsubst cdadar (X)

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

-(put 'cdadar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cddaar (X)
+(defsubst cddaar (X)

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

-(put 'cddaar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cadddr (X)
+(defsubst cadddr (X)

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

-(put 'cadddr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cddadr (X)
+(defsubst cddadr (X)

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

-(put 'cddadr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cdaddr (X)
+(defsubst cdaddr (X)

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

-(put 'cdaddr 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cdddar (X)
+(defsubst cdddar (X)

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

-(put 'cdddar 'byte-compile 'byte-compile-ca*d*r)

 
 

-(defun cddddr (X)
+(defsubst cddddr (X)

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

-(put 'cddddr 'byte-compile 'byte-compile-ca*d*r)

 \f
 ;;; some inverses of the accessors are needed for setf purposes
 
 \f
 ;;; some inverses of the accessors are needed for setf purposes
 

-(defun setnth (n list newval)
+(defsubst 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."
   "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))))
+  (when (< n 0)
+    (error "N must be 0 or greater, not %d" n))
+  (while (> n 0)
+    (setq list (cdr list)
+          n    (- n 1)))
+  ;; here only if (zerop n)
+  (rplaca list (car newval))
+  (rplacd list (cdr newval))
+  newval)

 \f
 ;;; A-lists machinery
 
 \f
 ;;; A-lists machinery
 

-(defun acons (key item alist)
+(defsubst 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))
   "Return a new alist with KEY paired with ITEM; otherwise like ALIST.
 Does not copy ALIST."
   (cons (cons key item) alist))


@@ -1066,6 +968,7 @@ have the same length."
       ((endp kptr) result)
     (setq result (acons key item result))))
 
       ((endp kptr) result)
     (setq result (acons key item result))))
 

+;;;; end of cl-lists.el

 \f
 ;;;; SEQUENCES
 ;;;; Emacs Lisp provides many of the 'sequences' functionality of
 \f
 ;;;; SEQUENCES
 ;;;; Emacs Lisp provides many of the 'sequences' functionality of


@@ -1073,18 +976,19 @@ have the same length."
 ;;;; 
 
 
 ;;;; 
 
 

-(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.")
+(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.")
+(defkeyword :initial-value  "For the syntax of #'reduce")

 \f
 (defun some     (pred seq &rest moreseqs)
   "Test PREDICATE on each element of SEQUENCE; is it ever non-nil?
 \f
 (defun some     (pred seq &rest moreseqs)
   "Test PREDICATE on each element of SEQUENCE; is it ever non-nil?


@@ -1316,7 +1220,7 @@ True if an -if style function was called and ITEM satisfies the
 predicate under :predicate in KLIST."
   (let ((predicate (extract-from-klist klist :predicate))
         (keyfn     (extract-from-klist klist :key 'identity)))
 predicate under :predicate in KLIST."
   (let ((predicate (extract-from-klist klist :predicate))
         (keyfn     (extract-from-klist klist :key 'identity)))

-    (funcall predicate item (funcall keyfn elt))))
+    (funcall predicate (funcall keyfn item))))

 
 (defun elt-satisfies-if-not-p (item klist)
   "(elt-satisfies-if-not-p ITEM KLIST) => t or nil
 
 (defun elt-satisfies-if-not-p (item klist)
   "(elt-satisfies-if-not-p ITEM KLIST) => t or nil


@@ -1325,7 +1229,7 @@ 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 klist :predicate))
         (keyfn     (extract-from-klist klist :key 'identity)))
 the predicate under :predicate in KLIST."
   (let ((predicate (extract-from-klist klist :predicate))
         (keyfn     (extract-from-klist klist :key 'identity)))

-    (not (funcall predicate item (funcall keyfn elt)))))
+    (not (funcall predicate (funcall keyfn item)))))

 
 (defun elts-match-under-klist-p (e1 e2 klist)
   "(elts-match-under-klist-p E1 E2 KLIST) => t or nil
 
 (defun elts-match-under-klist-p (e1 e2 klist)
   "(elts-match-under-klist-p E1 E2 KLIST) => t or nil


@@ -1434,7 +1338,7 @@ if clumsier, control over this feature."
                                             allow-other-keys)))
                           (nreverse forms)))
        body))))
                                             allow-other-keys)))
                           (nreverse forms)))
        body))))

-(put 'with-keyword-args 'lisp-indent-function 1)
+(put 'with-keyword-args 'lisp-indent-hook 1)

 
 \f
 ;;; REDUCE
 
 \f
 ;;; REDUCE


@@ -1454,7 +1358,7 @@ if clumsier, control over this feature."
 ;;; extract a value with (extract-from-klist KLIST KEY [DEFAULT]).
 
 (defun reduce (function sequence &rest kargs)
 ;;; extract a value with (extract-from-klist KLIST KEY [DEFAULT]).
 
 (defun reduce (function sequence &rest kargs)

-  "Apply FUNCTION (a function of two arguments) to succesive pairs of elements
+  "Apply FUNCTION (a function of two arguments) to successive pairs of elements

 from SEQUENCE.  Some keyword arguments are valid after FUNCTION and SEQUENCE:
 :from-end       If non-nil, process the values backwards
 :initial-value  If given, prefix it to the SEQUENCE.  Suffix, if :from-end
 from SEQUENCE.  Some keyword arguments are valid after FUNCTION and SEQUENCE:
 :from-end       If non-nil, process the values backwards
 :initial-value  If given, prefix it to the SEQUENCE.  Suffix, if :from-end


@@ -1513,16 +1417,17 @@ returned."
 ;;;; Both list and sequence functions are considered here together.  This
 ;;;; doesn't fit any more with the original split of functions in files.
 
 ;;;; Both list and sequence functions are considered here together.  This
 ;;;; doesn't fit any more with the original split of functions in files.
 

-(defun member (item list &rest kargs)
+(defun cl-member (item list &rest kargs)

   "Look for ITEM in LIST; return first tail of LIST the car of whose first
   "Look for ITEM in LIST; return first tail of LIST the car of whose first

-cons cell tests the same as ITEM.  Admits arguments :key, :test, and :test-not."
+cons cell tests the same as ITEM.  Admits arguments :key, :test, and
+:test-not."

   (if (null kargs)                      ;treat this fast for efficiency
       (memq item list)
     (let* ((klist     (build-klist kargs '(:test :test-not :key)))
            (test      (extract-from-klist klist :test))
            (testnot   (extract-from-klist klist :test-not))
            (key       (extract-from-klist klist :key 'identity)))
   (if (null kargs)                      ;treat this fast for efficiency
       (memq item list)
     (let* ((klist     (build-klist kargs '(:test :test-not :key)))
            (test      (extract-from-klist klist :test))
            (testnot   (extract-from-klist klist :test-not))
            (key       (extract-from-klist klist :key 'identity)))

-      ;; another workaround allegledly for speed
+      ;; another workaround allegedly for speed, BLAH

       (if (and (or (eq test 'eq) (eq test 'eql)
                    (eq test (symbol-function 'eq))
                    (eq test (symbol-function 'eql)))
       (if (and (or (eq test 'eq) (eq test 'eql)
                    (eq test (symbol-function 'eq))
                    (eq test (symbol-function 'eql)))


@@ -1569,11 +1474,11 @@ cons cell tests the same as ITEM.  Admits arguments :key, :test, and :test-not."
 ;;;;       (quiroz@cs.rochester.edu)
 
 ;;; Lisp indentation information
 ;;;;       (quiroz@cs.rochester.edu)
 
 ;;; Lisp indentation information

-(put 'multiple-value-bind  'lisp-indent-function 2)
-(put 'multiple-value-setq  'lisp-indent-function 2)
-(put 'multiple-value-list  'lisp-indent-function nil)
-(put 'multiple-value-call  'lisp-indent-function 1)
-(put 'multiple-value-prog1 'lisp-indent-function 1)
+(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
 
 ;;; Global state of the package is kept here
 (defvar *mvalues-values* nil


@@ -1599,7 +1504,7 @@ the first value."
   (car *mvalues-values*))
 
 (defun values-list (&optional val-forms)
   (car *mvalues-values*))
 
 (defun values-list (&optional val-forms)

-  "Produce multiple values (zero or mode).  Each element of LIST is one value.
+  "Produce multiple values (zero or more).  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'"
 This is equivalent to (apply 'values LIST)."
   (cond ((nlistp val-forms)
          (error "Argument to values-list must be a list, not `%s'"


@@ -1710,29 +1615,29 @@ the length of VARS (a list of symbols).  VALS is just a fresh symbol."
 ;;;;       (quiroz@cs.rochester.edu)
 
 
 ;;;;       (quiroz@cs.rochester.edu)
 
 

-(defun plusp (number)
+(defsubst plusp (number)

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

-(defun minusp (number)
+(defsubst minusp (number)

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

-(defun oddp (number)
+(defsubst oddp (number)

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

-(defun evenp (number)
+(defsubst evenp (number)

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

-(defun abs (number)
+(defsubst abs (number)

   "Return the absolute value of NUMBER."
   (if (< number 0)
       (- number)
     number))
 
   "Return the absolute value of NUMBER."
   (if (< number 0)
       (- number)
     number))
 

-(defun signum (number)
+(defsubst signum (number)

   "Return -1, 0 or 1 according to the sign of NUMBER."
   (cond ((< number 0)
          -1)
   "Return -1, 0 or 1 according to the sign of NUMBER."
   (cond ((< number 0)
          -1)


@@ -1760,7 +1665,7 @@ The arguments must be integers.  With no arguments, value is zero."
            (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
            (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.
+                 (ds (min absa absb))   ;successive divisions.

                  ;; intermediate results
                  (q 0)
                  (r 0)
                  ;; intermediate results
                  (q 0)
                  (r 0)


@@ -1819,64 +1724,61 @@ equal to the real square root of the argument."
                  done   (or (= new approx) (= new (+ approx 1)))
                  approx new)))))
 \f
                  done   (or (= new approx) (= new (+ approx 1)))
                  approx new)))))
 \f

-(defun floor (number &optional divisor)
+(defun cl-floor (number &optional divisor)

   "Divide DIVIDEND by DIVISOR, rounding toward minus infinity.
 DIVISOR defaults to 1.  The remainder is produced as a second value."
   "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                          ;opposite-signs case
-             (if (zerop r)
-                 (values (- q) 0)
-               (let ((q (- (+ q 1))))
-                 (values q (- number (* q divisor)))))))))))
-
-(defun ceiling (number &optional divisor)
+  (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                     ;opposite-signs case
+                  (if (zerop r)
+                      (values (- q) 0)
+                    (let ((q (- (+ q 1))))
+                      (values q (- number (* q divisor)))))))))))
+
+(defun cl-ceiling (number &optional divisor)

   "Divide DIVIDEND by DIVISOR, rounding toward plus infinity.
 DIVISOR defaults to 1.  The remainder is produced as a second value."
   "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))
-            ((plusp s)
-             (values (+ q 1) (- r divisor)))
-            (t
-             (values (- q) (+ number (* q divisor)))))))))
-\f
-(defun truncate (number &optional divisor)
+  (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 1) (- r divisor)))
+                 (t
+                  (values (- q) (+ number (* q divisor)))))))))
+\f
+(defun cl-truncate (number &optional divisor)

   "Divide DIVIDEND by DIVISOR, rounding toward zero.
 DIVISOR defaults to 1.  The remainder is produced as a second value."
   "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)                  ;same as floor
-             (values q r))
-            (t                          ;same as ceiling
-             (values (- q) (+ number (* q divisor)))))))))
-
-(defun round (number &optional divisor)
+  (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)             ;same as floor
+                  (values q r))
+                 (t                     ;same as ceiling
+                  (values (- q) (+ number (* q divisor)))))))))
+
+(defun cl-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
   "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


@@ -1899,18 +1801,25 @@ DIVISOR defaults to 1.  The remainder is produced as a second value."
              (setq r (- number (* q divisor)))
              (values q r))))))
 \f
              (setq r (- number (* q divisor)))
              (values q r))))))
 \f

-(defun mod (number divisor)
+;;; These two functions access the implementation-dependent representation of
+;;; the multiple value returns.
+
+(defun cl-mod (number divisor)

   "Return remainder of X by Y (rounding quotient toward minus infinity).
   "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))
+That is, the remainder goes with the quotient produced by `cl-floor'.
+Emacs Lisp hint:
+If you know that both arguments are positive, use `%' instead for speed."
+  (cl-floor number divisor)
+  (cadr *mvalues-values*))

 
 (defun rem (number divisor)
   "Return remainder of X by Y (rounding quotient toward zero).
 
 (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))
-
+That is, the remainder goes with the quotient produced by `cl-truncate'.
+Emacs Lisp hint:
+If you know that both arguments are positive, use `%' instead for speed."
+  (cl-truncate number divisor)
+  (cadr *mvalues-values*))
+\f

 ;;; internal utilities
 ;;;
 ;;; safe-idiv performs an integer division with positive numbers only.
 ;;; internal utilities
 ;;;
 ;;; safe-idiv performs an integer division with positive numbers only.


@@ -1922,16 +1831,14 @@ That is, the remainder goes with the quotient produced by `truncate'."
 
 (defun safe-idiv (a b)
   "SAFE-IDIV A B => Q R S
 
 (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))))
+Q=|A|/|B|, S is the sign of A/B, R is the rest A - S*Q*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* ((q (/ (abs a) (abs b)))
+         (s (* (signum a) (signum b)))
+         (r (- a (* s q b))))

     (values q r s)))
 
 ;;;; end of cl-arith.el
     (values q r s)))
 
 ;;;; end of cl-arith.el


@@ -1992,22 +1899,29 @@ the next PLACE is evaluated."
                          (setq head (car place))
                          (symbolp head)
                          (setq updatefn (get head :setf-update-fn)))
                          (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)))))
+                    ;; dispatch on the type of update function
+                   (cond ((and (consp updatefn) (eq (car updatefn) 'lambda))
+                          (cons 'funcall
+                                (cons (list 'function updatefn)
+                                      (append (cdr place) (list value)))))
+                         ((and (symbolp updatefn)
+                                (fboundp updatefn)
+                                (let ((defn (symbol-function updatefn)))
+                                  (or (subrp defn)
+                                      (and (consp defn)
+                                          (or (eq (car defn) 'lambda)
+                                              (eq (car defn) 'macro))))))
+                          (cons updatefn (append (cdr place) (list value))))
+                         (t
+                           (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)))))))))
                    (t
                     (error "no `setf' update-function for `%s'"
                            (prin1-to-string place)))))))))


@@ -2027,8 +1941,9 @@ updating called for."
            (prin1-to-string accessfn)))
   ;; update properties
   (list 'progn
            (prin1-to-string accessfn)))
   ;; update properties
   (list 'progn

-        (list 'put (list 'quote accessfn)
-              :setf-update-fn (list 'function updatefn))
+       (list 'eval-and-compile
+             (list 'put (list 'quote accessfn)
+                   :setf-update-fn (list 'function updatefn)))

         (list 'put (list 'quote accessfn) :setf-update-doc docstring)
         ;; any better thing to return?
         (list 'quote accessfn)))
         (list 'put (list 'quote accessfn) :setf-update-doc docstring)
         ;; any better thing to return?
         (list 'quote accessfn)))


@@ -2053,7 +1968,7 @@ updating called for."
 
 (defsetf apply
   (lambda (&rest args)
 
 (defsetf apply
   (lambda (&rest args)

-    ;; dissasemble the calling form
+    ;; disassemble 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"
     ;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too)
     (let* ((fnform (car args))          ;functional form
            (applyargs (append           ;arguments "to apply fnform"


@@ -2363,6 +2278,70 @@ Thus, the values rotate through the PLACEs.  Returns nil."
                        (append (cdr newsyms) (list (car newsyms)))))
       nil))))
 \f
                        (append (cdr newsyms) (list (car newsyms)))))
       nil))))
 \f

+;;; GETF, REMF, and REMPROP
+;;;
+
+(defun getf (place indicator &optional default)
+  "Return PLACE's PROPNAME property, or DEFAULT if not present."
+  (while (and place (not (eq (car place) indicator)))
+    (setq place (cdr (cdr place))))
+  (if place
+      (car (cdr place))
+    default))
+
+(defmacro getf$setf$method (place indicator default &rest newval)
+  "SETF method for GETF.  Not for public use."
+  (case (length newval)
+    (0 (setq newval default default nil))
+    (1 (setq newval (car newval)))
+    (t (error "Wrong number of arguments to (setf (getf ...)) form")))
+  (let ((psym (gentemp)) (isym (gentemp)) (vsym (gentemp)))
+    (list 'let (list (list psym place)
+                    (list isym indicator)
+                    (list vsym newval))
+         (list 'while
+               (list 'and psym
+                     (list 'not
+                           (list 'eq (list 'car psym) isym)))
+               (list 'setq psym (list 'cdr (list 'cdr psym))))
+         (list 'if psym
+               (list 'setcar (list 'cdr psym) vsym)
+               (list 'setf place
+                     (list 'nconc place (list 'list isym newval))))
+         vsym)))
+
+(defsetf getf
+  getf$setf$method)
+
+(defmacro remf (place indicator)
+  "Remove from the property list at PLACE its PROPNAME property.
+Returns non-nil if and only if the property existed."
+  (let ((psym (gentemp)) (isym (gentemp)))
+    (list 'let (list (list psym place) (list isym indicator))
+         (list 'cond
+               (list (list 'eq isym (list 'car psym))
+                     (list 'setf place (list 'cdr (list 'cdr psym)))
+                     t)
+               (list t
+                     (list 'setq psym (list 'cdr psym))
+                     (list 'while
+                           (list 'and (list 'cdr psym)
+                                 (list 'not
+                                       (list 'eq (list 'car (list 'cdr psym))
+                                             isym)))
+                           (list 'setq psym (list 'cdr (list 'cdr psym))))
+                     (list 'cond
+                           (list (list 'cdr psym)
+                                 (list 'setcdr psym
+                                       (list 'cdr
+                                             (list 'cdr (list 'cdr psym))))
+                                 t)))))))
+
+(defun remprop (symbol indicator)
+  "Remove SYMBOL's PROPNAME property, returning non-nil if it was present."
+  (remf (symbol-plist symbol) indicator))
+  
+\f

 ;;;; STRUCTS
 ;;;;    This file provides the structures mechanism.  See the
 ;;;;    documentation for Common-Lisp's defstruct.  Mine doesn't
 ;;;; STRUCTS
 ;;;;    This file provides the structures mechanism.  See the
 ;;;;    documentation for Common-Lisp's defstruct.  Mine doesn't


@@ -2404,7 +2383,7 @@ Each option is either a symbol, or a list of a keyword symbol taken from the
 list \{:conc-name, :copier, :constructor, :predicate, :include,
 :print-function, :type, :initial-offset\}.  The meanings of these are as in
 CLtL, except that no BOA-constructors are provided, and the options
 list \{:conc-name, :copier, :constructor, :predicate, :include,
 :print-function, :type, :initial-offset\}.  The meanings of these are as in
 CLtL, except that no BOA-constructors are provided, and the options

-\{:print-fuction, :type, :initial-offset\} are ignored quietly.  All these
+\{:print-function, :type, :initial-offset\} are ignored quietly.  All these

 structs are named, in the sense that their names can be used for type
 discrimination.
 
 structs are named, in the sense that their names can be used for type
 discrimination.
 


@@ -2523,9 +2502,7 @@ them.  `setf' of the accessors sets their values."
                                        (list 'quote name)
                                        'args))))
                (list 'fset (list 'quote copier)
                                        (list 'quote name)
                                        'args))))
                (list 'fset (list 'quote copier)

-                     (list 'function
-                           (list 'lambda (list 'struct)
-                                 (list 'copy-sequence 'struct))))
+                     (list 'function 'copy-sequence))

                (let ((typetag (gensym)))
                  (list 'fset (list 'quote predicate)
                        (list 
                (let ((typetag (gensym)))
                  (list 'fset (list 'quote predicate)
                        (list 


@@ -2562,7 +2539,7 @@ them.  `setf' of the accessors sets their values."
               (list
                (cons 'vector
                      (mapcar
               (list
                (cons 'vector
                      (mapcar

-                      '(lambda (x) (list 'quote x))
+                      (function (lambda (x) (list 'quote x)))

                       (cons name slots)))))
         ;; generate code
         (cons 'progn
                       (cons name slots)))))
         ;; generate code
         (cons 'progn


@@ -3012,7 +2989,7 @@ Beware: nconc destroys its first argument!  See copy-list."
 
 ;;; Copiers
 
 
 ;;; Copiers
 

-(defun copy-list (list)
+(defsubst copy-list (list)

   "Build a copy of LIST"
   (append list '()))
 
   "Build a copy of LIST"
   (append list '()))
 


@@ -3158,7 +3135,28 @@ returns false, that tail of the list if returned.  Else NIL."
 No checking is even attempted.  This is just for compatibility with
 Common-Lisp codes."
   form)
 No checking is even attempted.  This is just for compatibility with
 Common-Lisp codes."
   form)

+\f
+;;; Due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91)
+(put 'progv 'common-lisp-indent-hook '(4 4 &body))
+(defmacro progv (vars vals &rest body)
+  "progv vars vals &body forms
+bind vars to vals then execute forms.
+If there are more vars than vals, the extra vars are unbound, if
+there are more vals than vars, the extra vals are just ignored."
+  (` (progv$runtime (, vars) (, vals) (function (lambda () (,@ body))))))
+
+;;; To do this efficiently, it really needs to be a special form...
+(defun progv$runtime (vars vals body)
+  (eval (let ((vars-n-vals nil)
+             (unbind-forms nil))
+         (do ((r vars (cdr r))
+              (l vals (cdr l)))
+             ((endp r))
+           (push (list (car r) (list 'quote (car l))) vars-n-vals)
+           (if (null l)
+               (push (` (makunbound '(, (car r)))) unbind-forms)))
+         (` (let (, vars-n-vals) (,@ unbind-forms) (funcall '(, body)))))))

 
 (provide 'cl)
 
 
 (provide 'cl)
 

-;;; cl.el ends here
+;;;; end of cl.el