Mercurial > hg > xemacs-beta
changeset 5219:2d0937dc83cf
Tidying of CL files; make docstrings read better, remove commented-out code
2010-05-30 Aidan Kehoe <kehoea@parhasard.net>
* cl.el: Remove extraneous empty lines.
Remove the commented-out Lisp implementation of #'last,
#'copy-list.
Remove #'cl-maclisp-member.
(acons, pairlis): Have the argument list reflect the docstring for
these functions.
* cl-macs.el (defun*): Have the argument list reflect the
docstring.
Document the syntax of keywords in ARGLIST.
(defmacro*): Have the argument list reflect the docstring.
Document &body, &whole and &environment.
(function*): Have the argument list reflect the docstring.
(loop): Have the argument list reflect the docstring.
(eval-when, dolist, dotimes, do-symbols, flet, labels, macrolet,
symbol-macrolet):
Specify the argument list using the arguments: (...) syntax.
(define-setf-method, rotatef, defsubst*): Have the argument list
reflect the docstring.
(letf, letf*):
Specify the argument list using the arguments: (...) syntax.
(svref, acons, pairlis): Add compiler macros for these functions.
* cl-extra.el: Remove the commented-out Lisp implementation of
#'equalp. If we want to look at it, it's in version control.
(cl-expt): Remove this. The subr #'expt is always available.
Call #'cl-float-limits at dump time.
Remove the commented-out Lisp implementation of #'subseq.
(concatenate): Use (error 'invalid-argument ...) here, if TYPE is
not understood.
(list-length): Don't manually get the length of a list, call
#'length and return nil if the list is circular.
* byte-optimize.el (equalp): This needs
byte-optimize-binary-predicate as its optimizer, as do the other
equality predicates.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sun, 30 May 2010 13:27:36 +0100 |
parents | ec2ddc82f10d |
children | ac6846067766 |
files | lisp/ChangeLog lisp/byte-optimize.el lisp/cl-extra.el lisp/cl-macs.el lisp/cl-seq.el lisp/cl.el |
diffstat | 6 files changed, 188 insertions(+), 296 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sat May 29 15:19:54 2010 +0100 +++ b/lisp/ChangeLog Sun May 30 13:27:36 2010 +0100 @@ -1,3 +1,42 @@ +2010-05-30 Aidan Kehoe <kehoea@parhasard.net> + + * cl.el: Remove extraneous empty lines. + Remove the commented-out Lisp implementation of #'last, + #'copy-list. + Remove #'cl-maclisp-member. + (acons, pairlis): Have the argument list reflect the docstring for + these functions. + + * cl-macs.el (defun*): Have the argument list reflect the + docstring. + Document the syntax of keywords in ARGLIST. + (defmacro*): Have the argument list reflect the docstring. + Document &body, &whole and &environment. + (function*): Have the argument list reflect the docstring. + (loop): Have the argument list reflect the docstring. + (eval-when, dolist, dotimes, do-symbols, flet, labels, macrolet, + symbol-macrolet): + Specify the argument list using the arguments: (...) syntax. + (define-setf-method, rotatef, defsubst*): Have the argument list + reflect the docstring. + (letf, letf*): + Specify the argument list using the arguments: (...) syntax. + (svref, acons, pairlis): Add compiler macros for these functions. + + * cl-extra.el: Remove the commented-out Lisp implementation of + #'equalp. If we want to look at it, it's in version control. + (cl-expt): Remove this. The subr #'expt is always available. + Call #'cl-float-limits at dump time. + Remove the commented-out Lisp implementation of #'subseq. + (concatenate): Use (error 'invalid-argument ...) here, if TYPE is + not understood. + (list-length): Don't manually get the length of a list, call + #'length and return nil if the list is circular. + + * byte-optimize.el (equalp): This needs + byte-optimize-binary-predicate as its optimizer, as do the other + equality predicates. + 2010-05-16 Aidan Kehoe <kehoea@parhasard.net> * files.el (default-file-system-ignore-case):
--- a/lisp/byte-optimize.el Sat May 29 15:19:54 2010 +0100 +++ b/lisp/byte-optimize.el Sun May 30 13:27:36 2010 +0100 @@ -877,6 +877,7 @@ (put 'eq 'byte-optimizer 'byte-optimize-binary-predicate) (put 'eql 'byte-optimizer 'byte-optimize-binary-predicate) (put 'equal 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'equalp 'byte-optimizer 'byte-optimize-binary-predicate) (put 'string= 'byte-optimizer 'byte-optimize-binary-predicate) (put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate)
--- a/lisp/cl-extra.el Sat May 29 15:19:54 2010 +0100 +++ b/lisp/cl-extra.el Sun May 30 13:27:36 2010 +0100 @@ -51,10 +51,6 @@ (eval-when-compile (require 'obsolete)) -(or (memq 'cl-19 features) - (error "Tried to load `cl-extra' before `cl'!")) - - ;;; Type coercion. (defun coerce (x type) @@ -99,131 +95,7 @@ ((typep x type) x) (t (error "Can't coerce %s to type %s" x type)))) - -;;;;; Predicates. -;; -;;;; I'd actually prefer not to have this inline, the space -;;;; vs. amount-it's-called trade-off isn't reasonable, but that would -;;;; introduce bytecode problems with the compiler macro in cl-macs.el. -;;(defsubst cl-string-vector-equalp (cl-string cl-vector) -;; "Helper function for `equalp', which see." -;;; (check-argument-type #'stringp cl-string) -;;; (check-argument-type #'vector cl-vector) -;; (let ((cl-i (length cl-string)) -;; cl-char cl-other) -;; (when (= cl-i (length cl-vector)) -;; (while (and (>= (setq cl-i (1- cl-i)) 0) -;; (or (eq (setq cl-char (aref cl-string cl-i)) -;; (setq cl-other (aref cl-vector cl-i))) -;; (and (characterp cl-other) ; Note we want to call this -;; ; as rarely as possible, it -;; ; doesn't have a bytecode. -;; (eq (downcase cl-char) (downcase cl-other)))))) -;; (< cl-i 0)))) -;; -;;;; See comment on cl-string-vector-equalp above. -;;(defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector) -;; "Helper function for `equalp', which see." -;;; (check-argument-type #'bit-vector-p cl-bit-vector) -;;; (check-argument-type #'vectorp cl-vector) -;; (let ((cl-i (length cl-bit-vector)) -;; cl-other) -;; (when (= cl-i (length cl-vector)) -;; (while (and (>= (setq cl-i (1- cl-i)) 0) -;; (numberp (setq cl-other (aref cl-vector cl-i))) -;; ;; Differs from clisp here. -;; (= (aref cl-bit-vector cl-i) cl-other))) -;; (< cl-i 0)))) -;; -;;;; These two helper functions call equalp recursively, the two above have no -;;;; need to. -;;(defsubst cl-vector-array-equalp (cl-vector cl-array) -;; "Helper function for `equalp', which see." -;;; (check-argument-type #'vector cl-vector) -;;; (check-argument-type #'arrayp cl-array) -;; (let ((cl-i (length cl-vector))) -;; (when (= cl-i (length cl-array)) -;; (while (and (>= (setq cl-i (1- cl-i)) 0) -;; (equalp (aref cl-vector cl-i) (aref cl-array cl-i)))) -;; (< cl-i 0)))) -;; -;;(defsubst cl-hash-table-contents-equalp (cl-hash-table-1 cl-hash-table-2) -;; "Helper function for `equalp', which see." -;; (symbol-macrolet -;; ;; If someone has gone and fished the uninterned symbol out of this -;; ;; function's constants vector, and subsequently stored it as a value -;; ;; in a hash table, it's their own damn fault when -;; ;; `cl-hash-table-contents-equalp' gives the wrong answer. -;; ((equalp-default '#:equalp-default)) -;; (loop -;; for x-key being the hash-key in cl-hash-table-1 -;; using (hash-value x-value) -;; with y-value = nil -;; always (and (not (eq equalp-default -;; (setq y-value (gethash x-key cl-hash-table-2 -;; equalp-default)))) -;; (equalp y-value x-value))))) -;; -;;(defun equalp (x y) -;; "Return t if two Lisp objects have similar structures and contents. -;; -;;This is like `equal', except that it accepts numerically equal -;;numbers of different types (float, integer, bignum, bigfloat), and also -;;compares strings and characters case-insensitively. -;; -;;Arrays (that is, strings, bit-vectors, and vectors) of the same length and -;;with contents that are `equalp' are themselves `equalp'. -;; -;;Two hash tables are `equalp' if they have the same test (see -;;`hash-table-test'), if they have the same number of entries, and if, for -;;each entry in one hash table, its key is equivalent to a key in the other -;;hash table using the hash table test, and its value is `equalp' to the other -;;hash table's value for that key." -;; (cond ((eq x y)) -;; ((stringp x) -;; (if (stringp y) -;; (eq t (compare-strings x nil nil y nil nil t)) -;; (if (vectorp y) -;; (cl-string-vector-equalp x y) -;; ;; bit-vectors and strings are only equalp if they're -;; ;; zero-length: -;; (and (equal "" x) (equal #* y))))) -;; ((numberp x) -;; (and (numberp y) (= x y))) -;; ((consp x) -;; (while (and (consp x) (consp y) (equalp (car x) (car y))) -;; (setq x (cdr x) y (cdr y))) -;; (and (not (consp x)) (equalp x y))) -;; (t -;; ;; From here on, the type tests don't (yet) have bytecodes. -;; (let ((x-type (type-of x))) -;; (cond ((eq 'vector x-type) -;; (if (stringp y) -;; (cl-string-vector-equalp y x) -;; (if (vectorp y) -;; (cl-vector-array-equalp x y) -;; (if (bit-vector-p y) -;; (cl-bit-vector-vector-equalp y x))))) -;; ((eq 'character x-type) -;; (and (characterp y) -;; ;; If the characters are actually identical, the -;; ;; first eq test will have caught them above; we only -;; ;; need to check them case-insensitively here. -;; (eq (downcase x) (downcase y)))) -;; ((eq 'hash-table x-type) -;; (and (hash-table-p y) -;; (eq (hash-table-test x) (hash-table-test y)) -;; (= (hash-table-count x) (hash-table-count y)) -;; (cl-hash-table-contents-equalp x y))) -;; ((eq 'bit-vector x-type) -;; (if (bit-vector-p y) -;; (equal x y) -;; (if (vectorp y) -;; (cl-bit-vector-vector-equalp x y) -;; ;; bit-vectors and strings are only equalp if they're -;; ;; zero-length: -;; (and (equal "" y) (equal #* x))))) -;; (t (equal x y))))))) +;; XEmacs; #'equalp is in C. ;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon, #'some and #'every ;; are now in C, together with #'map-into, which was never in this file. @@ -348,7 +220,6 @@ (makunbound (car cl-progv-save))) (pop cl-progv-save))) - ;;; Numbers. (defun gcd (&rest args) @@ -381,14 +252,6 @@ g) (if (eq a 0) 0 (signal 'arith-error nil)))) -;; XEmacs addition -(defun cl-expt (x y) - "Return X raised to the power of Y. Works only for integer arguments." - (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0)) - (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2))))) -(or (and (fboundp 'expt) (subrp (symbol-function 'expt))) - (defalias 'expt 'cl-expt)) - ;; We can't use macrolet in this file; whence the literal macro ;; definition-and-call: ((macro . (lambda (&rest symbols) @@ -473,15 +336,6 @@ (and (numberp res) (/= res (/ res 2)) res)) (arith-error nil))) -(defvar most-positive-float) -(defvar most-negative-float) -(defvar least-positive-float) -(defvar least-negative-float) -(defvar least-positive-normalized-float) -(defvar least-negative-normalized-float) -(defvar float-epsilon) -(defvar float-negative-epsilon) - (defun cl-float-limits () (or most-positive-float (not (numberp '2e1)) (let ((x '2e0) y z) @@ -516,34 +370,12 @@ (setq float-negative-epsilon (* x 2)))) nil) +;; XEmacs; call cl-float-limits at dump time. +(cl-float-limits) ;;; Sequence functions. -;XEmacs -- our built-in is more powerful. -;(defun subseq (seq start &optional end) -; "Return the subsequence of SEQ from START to END. -;If END is omitted, it defaults to the length of the sequence. -;If START or END is negative, it counts from the end." -; (if (stringp seq) (substring seq start end) -; (let (len) -; (and end (< end 0) (setq end (+ end (setq len (length seq))))) -; (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) -; (cond ((listp seq) -; (if (> start 0) (setq seq (nthcdr start seq))) -; (if end -; (let ((res nil)) -; (while (>= (setq end (1- end)) start) -; (push (pop seq) res)) -; (nreverse res)) -; (copy-sequence seq))) -; (t -; (or end (setq end (or len (length seq)))) -; (let ((res (make-vector (max (- end start) 0) nil)) -; (i 0)) -; (while (< start end) -; (aset res i (aref seq start)) -; (setq i (1+ i) start (1+ start))) -; res)))))) +;; XEmacs; #'subseq is in C. (defun concatenate (type &rest seqs) "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." @@ -552,7 +384,7 @@ (vector (apply 'vconcat seqs)) (string (apply 'concat seqs)) (list (apply 'append (append seqs '(nil)))) - (t (error "Not a sequence type name: %s" type)))) + (t (error 'invalid-argument "Not a sequence type name" type)))) ;;; List functions. @@ -564,12 +396,12 @@ "Equivalent to (nconc (nreverse X) Y)." (nconc (nreverse x) y)) -(defun list-length (x) - "Return the length of a list. Return nil if list is circular." - (let ((n 0) (fast x) (slow x)) - (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) - (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) - (if fast (if (cdr fast) nil (1+ n)) n))) +(defun list-length (list) + "Return the length of LIST. Return nil if LIST is circular." + (if (listp list) + (condition-case nil (length list) (circular-list)) + ;; Error on not-a-list: + (car list))) (defun tailp (sublist list) "Return true if SUBLIST is a tail of LIST." @@ -579,7 +411,6 @@ (defalias 'cl-copy-tree 'copy-tree) - ;;; Property lists. ;; XEmacs: our `get' groks DEFAULT. @@ -824,8 +655,6 @@ (prog1 (cl-prettyprint form) (message "")))) - - (run-hooks 'cl-extra-load-hook) ;; XEmacs addition
--- a/lisp/cl-macs.el Sat May 29 15:19:54 2010 +0100 +++ b/lisp/cl-macs.el Sun May 30 13:27:36 2010 +0100 @@ -175,8 +175,8 @@ ;;; Program structure. ;;;###autoload -(defmacro defun* (name args &rest body) - "(defun* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. +(defmacro defun* (name arglist &optional docstring &rest body) + "Define NAME as a function. Like normal `defun', except ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...). @@ -193,7 +193,24 @@ bound to nil. -- &key specifies keyword arguments. The format of each argument is - VAR || ( { VAR || (KEYWORD VAR) } [INITFORM [SVAR]]) -- #### document me. + VAR || ( { VAR || (KEYWORD VAR) } [INITFORM [SVAR]]). + + If VAR is specified on its own, VAR is bound within BODY to the value + supplied by the caller for the corresponding keyword; for example, &key + my-value means callers write :my-value RUNTIME-EXPRESSION. + + If (VAR INITFORM) is specified, INITFORM is an expression evaluated at + runtime to determine a default value for VAR. + + If (VAR INITFORM SVAR) is specified, SVAR is variable available within + BODY that is non-nil if VAR was explicitly specified in the calling + expression. + + If ((KEYWORD VAR)) is specified, KEYWORD is the keyword to be used by + callers, and VAR is the corresponding variable binding within BODY. + + In calls to NAME, values for a given keyword may be supplied multiple + times. The first value is the only one used. -- &allow-other-keys means that if other keyword arguments are given that are not specifically list in the arg list, they are allowed, rather than an @@ -203,13 +220,13 @@ The format of each binding is VAR || (VAR [INITFORM]) -- exactly like the format of `let'/`let*' bindings. " - (let* ((res (cl-transform-lambda (cons args body) name)) + (let* ((res (cl-transform-lambda (list* arglist docstring body) name)) (form (list* 'defun name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) ;;;###autoload -(defmacro defmacro* (name args &rest body) - "(defmacro* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro. +(defmacro defmacro* (name arglist &optional docstring &rest body) + "Define NAME as a macro. Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...). @@ -219,7 +236,18 @@ &aux are allowed, as in `defun*'. -- Three additional lambda-list keywords are allowed: &body, &whole, and - &environment. #### Document me. + &environment: + + &body is equivalent to &rest, but is intended to indicate that the + following arguments are the body of some piece of code, and should be + indented as such. + + &whole must come first; it is followed by a single variable that, at + macro expansion time, reflects all the arguments supplied to the macro, + as if it had been declared with a single &rest argument. + + &environment specifies local semantics for various macros for use within + the expansion of BODY. See the ENVIRONMENT argument to `macroexpand'. -- The macro arg list syntax allows for \"destructuring\" -- see also `destructuring-bind', which destructures exactly like `defmacro*', and @@ -248,20 +276,20 @@ are ignored, not enough arguments cause the remaining parameters to receive a value of nil, etc. " - (let* ((res (cl-transform-lambda (cons args body) name)) + (let* ((res (cl-transform-lambda (list* arglist docstring body) name)) (form (list* 'defmacro name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) ;;;###autoload -(defmacro function* (func) - "(function* SYMBOL-OR-LAMBDA): introduce a function. +(defmacro function* (symbol-or-lambda) + "Introduce a function. Like normal `function', except that if argument is a lambda form, its ARGLIST allows full Common Lisp conventions." - (if (eq (car-safe func) 'lambda) - (let* ((res (cl-transform-lambda (cdr func) 'cl-none)) + (if (eq (car-safe symbol-or-lambda) 'lambda) + (let* ((res (cl-transform-lambda (cdr symbol-or-lambda) 'cl-none)) (form (list 'function (cons 'lambda (cdr res))))) (if (car res) (list 'progn (car res) form) form)) - (list 'function func))) + (list 'function symbol-or-lambda))) (defun cl-transform-function-property (func prop form) (let ((res (cl-transform-lambda form func))) @@ -555,10 +583,12 @@ ;;;###autoload (defmacro eval-when (when &rest body) - "(eval-when (WHEN...) BODY...): control when BODY is evaluated. + "Control when BODY is evaluated. If `compile' is in WHEN, BODY is evaluated when compiled at top-level. If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. -If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level." +If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. + +arguments: ((&rest WHEN) &body BODY)" (if (and (fboundp 'cl-compiling-file) (cl-compiling-file) (not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) @@ -768,8 +798,8 @@ (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) ;;;###autoload -(defmacro loop (&rest args) - "(loop CLAUSE...): The Common Lisp `loop' macro. +(defmacro loop (&rest clauses) + "The Common Lisp `loop' macro. The loop macro consists of a series of clauses, which do things like iterate variables, set conditions for exiting the loop, accumulating values @@ -1050,8 +1080,8 @@ Specify the name for block surrounding the loop, in place of nil. (See `block'.) " - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args)))))) - (list 'block nil (list* 'while t args)) + (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list clauses)))))) + (list 'block nil (list* 'while t clauses)) (let ((loop-name nil) (loop-bindings nil) (loop-body nil) (loop-steps nil) (loop-result nil) (loop-result-explicit nil) @@ -1059,8 +1089,8 @@ (loop-accum-var nil) (loop-accum-vars nil) (loop-initially nil) (loop-finally nil) (loop-map-form nil) (loop-first-flag nil) - (loop-destr-temps nil) (loop-symbol-macs nil)) - (setq args (append args '(cl-end-loop))) + (loop-destr-temps nil) (loop-symbol-macs nil) + (args (append clauses '(cl-end-loop)))) (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause)) (if loop-finish-flag (push (list (list loop-finish-flag t)) loop-bindings)) @@ -1646,9 +1676,11 @@ ;;;###autoload (defmacro dolist (spec &rest body) - "(dolist (VAR LIST [RESULT]) BODY...): loop over a list. + "Loop over a list. Evaluate BODY with VAR bound to each `car' from LIST, in turn. -Then evaluate RESULT to get return value, default nil." +Then evaluate RESULT to get return value, default nil. + +arguments: ((VAR LIST &optional RESULT) &body BODY)" (let ((temp (gensym "--dolist-temp--"))) (list 'block nil (list* 'let (list (list temp (nth 1 spec)) (car spec)) @@ -1661,10 +1693,12 @@ ;;;###autoload (defmacro dotimes (spec &rest body) - "(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times. + "Loop a certain number of times. Evaluate BODY with VAR bound to successive integers from 0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get return value, default -nil." +nil. + +arguments: ((VAR COUNT &optional RESULT) &body BODY)" (let ((temp (gensym "--dotimes-temp--"))) (list 'block nil (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) @@ -1674,9 +1708,11 @@ ;;;###autoload (defmacro do-symbols (spec &rest body) - "(dosymbols (VAR [OBARRAY [RESULT]]) BODY...): loop over all symbols. + "Loop over all symbols. Evaluate BODY with VAR bound to each interned symbol, or to each symbol -from OBARRAY." +from OBARRAY. + +arguments: ((VAR &optional OBARRAY RESULT) &body BODY)" ;; Apparently this doesn't have an implicit block. (list 'block nil (list 'let (list (car spec)) @@ -1718,11 +1754,13 @@ ;;; This should really have some way to shadow 'byte-compile properties, etc. ;;;###autoload (defmacro flet (bindings &rest body) - "(flet ((FUNC ARGLIST BODY...) ...) FORM...): make temporary function defns. + "Make temporary function definitions. This is an analogue of `let' that operates on the function cell of FUNC rather than its value cell. The FORMs are evaluated with the specified function definitions in place, then the definitions are undone (the FUNCs -go back to their previous definitions, or lack thereof)." +go back to their previous definitions, or lack thereof). + +arguments: (((FUNC ARGLIST &body BODY) &rest FUNCTIONS) &body FORM)" (list* 'letf* (mapcar #'(lambda (x) @@ -1743,9 +1781,11 @@ ;;;###autoload (defmacro labels (bindings &rest body) - "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings. + "Make temporary func bindings. This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully compliant with the Common Lisp standard." +Unlike `flet', this macro is fully compliant with the Common Lisp standard. + +arguments: (((FUNC ARGLIST &body BODY) &rest FUNCTIONS) &body FORM)" (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) (while bindings (let ((var (gensym))) @@ -1763,8 +1803,10 @@ ;; byte compilers. ;;;###autoload (defmacro macrolet (bindings &rest body) - "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns. -This is like `flet', but for macros instead of functions." + "Make temporary macro definitions. +This is like `flet', but for macros instead of functions. + +arguments: (((NAME ARGLIST &optional DOCSTRING &body body) &rest MACROS) &body FORM)" (if (cdr bindings) (list 'macrolet (list (car bindings)) (list* 'macrolet (cdr bindings) body)) @@ -1778,9 +1820,11 @@ ;;;###autoload (defmacro symbol-macrolet (bindings &rest body) - "(symbol-macrolet ((NAME EXPANSION) ...) FORM...): make symbol macro defns. + "Make symbol macro definitions. Within the body FORMs, references to the variable NAME will be replaced -by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)." +by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). + +arguments: (((NAME EXPANSION) &rest SYMBOL-MACROS) &body FORM)" (if (cdr bindings) (list 'symbol-macrolet (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body)) @@ -1992,20 +2036,20 @@ ;;; Generalized variables. ;;;###autoload -(defmacro define-setf-method (func args &rest body) - "(define-setf-method NAME ARGLIST BODY...): define a `setf' method. -This method shows how to handle `setf's to places of the form (NAME ARGS...). -The argument forms ARGS are bound according to ARGLIST, as if NAME were +(defmacro define-setf-method (name arglist &rest body) + "Define a `setf' method. +This method shows how to handle `setf's to places of the form (NAME ARGLIST...). +The argument forms are bound according to ARGLIST, as if NAME were going to be expanded as a macro, then the BODY forms are executed and must return a list of five elements: a temporary-variables list, a value-forms list, a store-variables list (of length one), a store-form, and an access- form. See `defsetf' for a simpler way to define most setf-methods." (append '(eval-when (compile load eval)) (if (stringp (car body)) - (list (list 'put (list 'quote func) '(quote setf-documentation) + (list (list 'put (list 'quote name) '(quote setf-documentation) (pop body)))) (list (cl-transform-function-property - func 'setf-method (cons args body))))) + name 'setf-method (cons arglist body))))) (defalias 'define-setf-expander 'define-setf-method) ;;;###autoload @@ -2566,18 +2610,18 @@ form))) ;;;###autoload -(defmacro rotatef (&rest args) - "(rotatef PLACE...): rotate left among PLACEs. +(defmacro rotatef (&rest places) + "Rotate left among PLACES. Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. Each PLACE may be a symbol, or any generalized variable allowed by `setf'." - (if (not (memq nil (mapcar 'symbolp args))) - (and (cdr args) + (if (not (memq nil (mapcar 'symbolp places))) + (and (cdr places) (let ((sets nil) - (first (car args))) - (while (cdr args) - (setq sets (nconc sets (list (pop args) (car args))))) - (nconc (list 'psetf) sets (list (car args) first)))) - (let* ((places (reverse args)) + (first (car places))) + (while (cdr places) + (setq sets (nconc sets (list (pop places) (car places))))) + (nconc (list 'psetf) sets (list (car places) first)))) + (let* ((places (reverse places)) (temp (gensym "--rotatef--")) (form temp)) (while (cdr places) @@ -2613,14 +2657,16 @@ ;;;###autoload (defmacro letf (bindings &rest body) - "(letf ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. + "Temporarily bind to PLACEs. This is the analogue of `let', but with generalized variables (in the sense of `setf') for the PLACEs. Each PLACE is set to the corresponding VALUE, then the BODY forms are executed. On exit, either normally or because of a `throw' or error, the PLACEs are set back to their original values. Note that this macro is *not* available in Common Lisp. As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', -the PLACE is not modified before executing BODY." +the PLACE is not modified before executing BODY. + +arguments: (((PLACE VALUE) &rest BINDINGS) &body BODY)" (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) (list* 'let bindings body) (let ((lets nil) @@ -2715,14 +2761,16 @@ ;;;###autoload (defmacro letf* (bindings &rest body) - "(letf* ((PLACE VALUE) ...) BODY...): temporarily bind to PLACEs. + "Temporarily bind to PLACES. This is the analogue of `let*', but with generalized variables (in the sense of `setf') for the PLACEs. Each PLACE is set to the corresponding VALUE, then the BODY forms are executed. On exit, either normally or because of a `throw' or error, the PLACEs are set back to their original values. Note that this macro is *not* available in Common Lisp. As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', -the PLACE is not modified before executing BODY." +the PLACE is not modified before executing BODY. + +arguments: (((PLACE VALUE) &rest BINDINGS) &body BODY)" (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) @@ -3163,26 +3211,29 @@ (byte-compile-normal-call form) (byte-compile-form form))) -(defmacro defsubst* (name args &rest body) - "(defsubst* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. +(defmacro defsubst* (name arglist &optional docstring &rest body) + "Define NAME as a function. Like `defun', except the function is automatically declared `inline', ARGLIST allows full Common Lisp conventions, and BODY is implicitly surrounded by (block NAME ...)." - (let* ((argns (cl-arglist-args args)) (p argns) - (pbody (cons 'progn body)) + (let* ((argns (cl-arglist-args arglist)) (p argns) + (exec-body (if (or (stringp docstring) (null docstring)) + body + (cons docstring body))) + (pbody (cons 'progn exec-body)) (unsafe (not (cl-safe-expr-p pbody)))) - (while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p)) + (while (and p (eq (cl-expr-contains arglist (car p)) 1)) (pop p)) (list 'progn (if p nil ; give up if defaults refer to earlier args (list 'define-compiler-macro name - (if (memq '&key args) - (list* '&whole 'cl-whole '&cl-quote args) - (cons '&cl-quote args)) + (if (memq '&key arglist) + (list* '&whole 'cl-whole '&cl-quote arglist) + (cons '&cl-quote arglist)) (list* 'cl-defsubst-expand (list 'quote argns) - (list 'quote (list* 'block name body)) + (list 'quote (list* 'block name exec-body)) (not (or unsafe (cl-expr-access-order pbody argns))) - (and (memq '&key args) 'cl-whole) unsafe argns))) - (list* 'defun* name args body)))) + (and (memq '&key arglist) 'cl-whole) unsafe argns))) + (list* 'defun* name arglist docstring body)))) (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole @@ -3652,6 +3703,15 @@ (define-compiler-macro stable-sort (&whole form &rest cl-rest) (cons 'sort* (cdr form))) +(define-compiler-macro svref (&whole form) + (cons 'aref (cdr form))) + +(define-compiler-macro acons (a b c) + `(cons (cons ,a ,b) ,c)) + +(define-compiler-macro pairlis (a b &optional c) + `(nconc (mapcar* #'cons ,a ,b) ,c)) + (mapc #'(lambda (y) (put (car y) 'side-effect-free t)
--- a/lisp/cl-seq.el Sat May 29 15:19:54 2010 +0100 +++ b/lisp/cl-seq.el Sun May 30 13:27:36 2010 +0100 @@ -50,10 +50,6 @@ ;;; Code: -(or (memq 'cl-19 features) - (error "Tried to load `cl-seq' before `cl'!")) - - ;;; Keyword parsing. This is special-cased here so that we can compile ;;; this file independent from cl-macs.
--- a/lisp/cl.el Sat May 29 15:19:54 2010 +0100 +++ b/lisp/cl.el Sun May 30 13:27:36 2010 +0100 @@ -99,17 +99,9 @@ ;;; Code: -(defvar cl-emacs-type (cond ((or (and (fboundp 'epoch::version) - (symbol-value 'epoch::version)) - (string-lessp emacs-version "19")) 18) - ((string-match "XEmacs" emacs-version) - 'lucid) - (t 19))) - (defvar cl-optimize-speed 1) (defvar cl-optimize-safety 1) - (defvar custom-print-functions nil "This is a list of functions that format user objects for printing. Each function is called in turn with three arguments: the object, the @@ -120,7 +112,6 @@ This variable is not used at present, but it is defined in hopes that a future Emacs interpreter will be able to use it.") - ;;; Predicates. (defun eql (a b) ; See compiler macro in cl-macs.el @@ -206,7 +197,6 @@ val (and (< end (length str)) (substring str end)))) - ;;; Control structures. ;; The macros `when' and `unless' are so useful that we want them to @@ -215,7 +205,6 @@ (defalias 'cl-map-extents 'map-extents) - ;;; Blocks and exits. ;; This used to be #'identity, but that didn't preserve multiple values in @@ -260,7 +249,6 @@ (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) cl-macro)) - ;;; Declarations. (defvar cl-compiling-file nil) @@ -289,7 +277,6 @@ (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body) (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when - ;;; Symbols. (defun cl-random-time () @@ -363,12 +350,13 @@ (defconst float-epsilon nil) (defconst float-negative-epsilon nil) - ;;; Sequence functions. (defalias 'copy-seq 'copy-sequence) -(defalias 'svref 'aref) +;; XEmacs; #'mapcar* is in C. + +(defalias 'svref 'aref) ;; Compiler macro in cl-macs.el ;;; List functions. @@ -530,16 +518,6 @@ (cdr (cdr (cdr (cdr x))))) ;;; `last' is implemented as a C primitive, as of 1998-11 -;;(defun last* (x &optional n) -;; "Returns the last link in the list LIST. -;;With optional argument N, returns Nth-to-last link (default 1)." -;; (if n -;; (let ((m 0) (p x)) -;; (while (consp p) (incf m) (pop p)) -;; (if (<= n 0) p -;; (if (< n m) (nthcdr (- m n) x) x))) -;; (while (consp (cdr x)) (pop x)) -;; x)) (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el "Return a new list with specified args as elements, cons'd to last arg. @@ -562,19 +540,6 @@ ;;; `copy-list' is implemented as a C primitive, as of 1998-11 -;(defun copy-list (list) -; "Return a copy of a list, which may be a dotted list. -;The elements of the list are not copied, just the list structure itself." -; (if (consp list) -; (let ((res nil)) -; (while (consp list) (push (pop list) res)) -; (prog1 (nreverse res) (setcdr res list))) -; (car list))) - -(defun cl-maclisp-member (item list) - (while (and list (not (equal item (car list)))) (setq list (cdr list))) - list) - (defalias 'cl-member 'memq) ; for compatibility with old CL package (defalias 'cl-floor 'floor*) (defalias 'cl-ceiling 'ceiling*) @@ -612,12 +577,16 @@ cl-tree (cons a d)))) (t cl-tree))) -(defun acons (a b c) +(defun acons (key value alist) "Return a new alist created by adding (KEY . VALUE) to ALIST." - (cons (cons a b) c)) + (cons (cons key value) alist)) -(defun pairlis (a b &optional c) (nconc (mapcar* 'cons a b) c)) - +(defun pairlis (keys values &optional alist) + "Make an alist from KEYS and VALUES. +Return a new alist composed by associating KEYS to corresponding VALUES; +the process stops as soon as KEYS or VALUES run out. +If ALIST is non-nil, the new pairs are prepended to it." + (nconc (mapcar* 'cons keys values) alist)) ;;; Miscellaneous. @@ -667,10 +636,8 @@ ((loop) defun (&rest &or symbolp form)) ((ignore-errors) 0 (&rest form)))) - ;;; This goes here so that cl-macs can find it if it loads right now. -(provide 'cl-19) ; usage: (require 'cl-19 "cl") - +(provide 'cl-19) ;;; Things to do after byte-compiler is loaded. ;;; As a side effect, we cause cl-macs to be loaded when compiling, so