xemacs-beta: lisp/cl-macs.el comparison

comparison lisp/cl-macs.el @ 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	2e528066e2fc
children	7789ae555c45

comparison

equal deleted inserted replaced

-:ec2ddc82f10d
+:2d0937dc83cf
 ;;; Program structure.
 ;;;###autoload
-(defmacro defun* (name args &rest body)
+(defmacro defun* (name arglist &optional docstring &rest body)
-"(defun* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
+"Define NAME as a function.
 Like normal `defun', except ARGLIST allows full Common Lisp conventions,
 and BODY is implicitly surrounded by (block NAME ...).
 \"Full Common Lisp conventions\" means that:
 INITFORM is omitted) and stored as VAR's value, and SVAR is bound to t.
 If an arguent is available for VAR, and INITFORM is unused, SVAR is
 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
 error being signalled.  They can be retrieved with an &rest form.
 -- &aux specifies extra bindings, exactly like a `let*' enclosing the body.
 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 defmacro* (name arglist &optional docstring &rest body)
-"(defmacro* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
+"Define NAME as a macro.
 Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
 and BODY is implicitly surrounded by (block NAME ...).
 \"Full Common Lisp conventions\" means that:
 -- The lambda-list keywords &optional, &rest, &key, &allow-other-keys, and
 &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
 `loop', which does a rather different way of destructuring.  Anywhere
 that a simple argument may appear, and (if following a lambda-list
 actual structure does not match the expected structure.  On the
 other hand, loop destructuring is lax -- extra arguments in a list
 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)
+(defmacro function* (symbol-or-lambda)
-"(function* SYMBOL-OR-LAMBDA): introduce a function.
+"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)
+(if (eq (car-safe symbol-or-lambda) 'lambda)
-(let* ((res (cl-transform-lambda (cdr func) 'cl-none))
+(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)))
 (append '(progn) (cdr (cdr (car res)))
 	    (list (list 'put (list 'quote func) (list 'quote prop)
 (defvar cl-not-toplevel nil)
 ;;;###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)))
 	    (cl-not-toplevel t))
 	(if (or (memq 'load when) (memq :load-toplevel when))
 (defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
 (defvar loop-result) (defvar loop-result-explicit)
 (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
 ;;;###autoload
-(defmacro loop (&rest args)
+(defmacro loop (&rest clauses)
-"(loop CLAUSE...): The Common Lisp `loop' macro.
+"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
 to be returned as the return value of the loop, and executing arbitrary
 blocks of code.  Each clause is processed in turn, and the loop executes its
 named NAME
 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))))))
+(if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list clauses))))))
-(list 'block nil (list* 'while t args))
+(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)
 	  (loop-result-var nil) (loop-finish-flag nil)
 	  (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))
+	  (loop-destr-temps nil) (loop-symbol-macs nil)
-(setq args (append args '(cl-end-loop)))
+(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))
 (if loop-first-flag
 	  (progn (push (list (list loop-first-flag t)) loop-bindings)
 						 (apply 'append sets)))))))
 	       (or (cdr endtest) '(nil)))))
 ;;;###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))
 		 (list* 'while temp (list 'setq (car spec) (list 'car temp))
 			(append body (list (list 'setq temp
 		     (cons (list 'setq (car spec) nil) (cdr (cdr spec)))
 		   '(nil))))))
 ;;;###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))
 		 (list* 'while (list '< (car spec) temp)
 			(append body (list (list 'incf (car spec)))))
 		 (or (cdr (cdr spec)) '(nil))))))
 ;;;###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))
 	      (list* 'mapatoms
 		     (list 'function (list* 'lambda (list (car spec)) body))
 	      '(cl-progv-after))))
 ;;; 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)
 	      (if (or (and (fboundp (car x))
 			   (eq (car-safe (symbol-function (car x))) 'macro))
 	  bindings)
 	 body))
 ;;;###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)))
 	(push var vars)
 	(push (list 'function* (cons 'lambda (cdar bindings))) sets)
 ;; The following ought to have a better definition for use with newer
 ;; byte compilers.
 ;;;###autoload
 (defmacro macrolet (bindings &rest body)
-"(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns.
+"Make temporary macro definitions.
-This is like `flet', but for macros instead of functions."
+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))
 (if (null bindings) (cons 'progn body)
 (let* ((name (caar bindings))
 			    (cons (list* name 'lambda (cdr res))
 				  cl-macro-environment))))))
 ;;;###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))
 (if (null bindings) (cons 'progn body)
 (cl-macroexpand-all (cons 'progn body)
 ;;; Generalized variables.
 ;;;###autoload
-(defmacro define-setf-method (func args &rest body)
+(defmacro define-setf-method (name arglist &rest body)
-"(define-setf-method NAME ARGLIST BODY...): define a `setf' method.
+"Define a `setf' method.
-This method shows how to handle `setf's to places of the form (NAME ARGS...).
+This method shows how to handle `setf's to places of the form (NAME ARGLIST...).
-The argument forms ARGS are bound according to ARGLIST, as if NAME were
+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
 (defmacro defsetf (func arg1 &rest args)
 "(defsetf NAME FUNC): define a `setf' method.
 			   (list 'prog1 (nth 2 method)
 				 (cl-setf-do-store (nth 1 method) form))))))
 form)))
 ;;;###autoload
-(defmacro rotatef (&rest args)
+(defmacro rotatef (&rest places)
-"(rotatef PLACE...): rotate left among 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)))
+(if (not (memq nil (mapcar 'symbolp places)))
-(and (cdr args)
+(and (cdr places)
 	   (let ((sets nil)
-		 (first (car args)))
+		 (first (car places)))
-	     (while (cdr args)
+	     (while (cdr places)
-	       (setq sets (nconc sets (list (pop args) (car args)))))
+	       (setq sets (nconc sets (list (pop places) (car places)))))
-	     (nconc (list 'psetf) sets (list (car args) first))))
+	     (nconc (list 'psetf) sets (list (car places) first))))
-(let* ((places (reverse args))
+(let* ((places (reverse places))
 	   (temp (gensym "--rotatef--"))
 	   (form temp))
 (while (cdr places)
 	(let ((method (cl-setf-do-modify (pop places) 'unsafe)))
 	  (setq form (list 'let* (car method)
 ;;
 ;; Aidan Kehoe, Fr Nov 13 16:12:21 GMT 2009
 ;;;###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)
 	  (rev (reverse bindings)))
 (while rev
 		rev (cdr rev))))
 (list* 'let* lets body))))
 ;;;###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))
 (while bindings
 (setq body (list (list* 'letf (list (pop bindings)) body))))
 (defun cl-byte-compile-compiler-macro (form)
 (if (eq form (setq form (compiler-macroexpand form)))
 (byte-compile-normal-call form)
 (byte-compile-form form)))
-(defmacro defsubst* (name args &rest body)
+(defmacro defsubst* (name arglist &optional docstring &rest body)
-"(defsubst* NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
+"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)
+(let* ((argns (cl-arglist-args arglist)) (p argns)
-	 (pbody (cons 'progn body))
+(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)
+		  (if (memq '&key arglist)
-		      (list* '&whole 'cl-whole '&cl-quote args)
+		      (list* '&whole 'cl-whole '&cl-quote arglist)
-		    (cons '&cl-quote args))
+		    (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)))
+			 (and (memq '&key arglist) 'cl-whole) unsafe argns)))
-	  (list* 'defun* name args body))))
+	  (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
 (if (cl-simple-exprs-p argvs) (setq simple t))
 (let ((lets (delq nil
 	,(compiled-function-stack-depth compiled))))))
 (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)
 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
 (put (car y) 'cl-compiler-macro

Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5219:2d0937dc83cf