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

comparison lisp/cl-macs.el @ 5118:e0db3c197671 ben-lisp-object

merge up to latest default branch, doesn't compile yet

author	Ben Wing <ben@xemacs.org>
date	Sat, 26 Dec 2009 21:18:49 -0600
parents	e29fcfd8df5f
children	95b04754ea8c 8b50bee3c88c

comparison

equal deleted inserted replaced

-:3742ea8250b5
+:e0db3c197671
 '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
 (defvar cl-macro-environment nil)
 (defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
 (defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
-(defvar arglist-visited)
 ;; npak@ispras.ru
 (defun cl-upcase-arg (arg)
 ;; Changes all non-keyword symbols in `ARG' to symbols
 ;; with name in upper case.
 ;; ARG is either symbol or list of symbols or lists
 (cond ((symbolp arg)
 	 ;; Do not upcase &optional, &key etc.
-	 (if (memq arg lambda-list-keywords) arg
+	 (if (memq arg lambda-list-keywords)
-	   (intern (upcase (symbol-name arg)))))
+arg
+	   (make-symbol (upcase (symbol-name arg)))))
 	((listp arg)
-	 (if (memq arg arglist-visited) (error 'circular-list '(arg)))
-	 (push arg arglist-visited)
 	 (let ((arg (copy-list arg)) junk)
 	   ;; Clean the list
 	   (let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
 	   (if (setq junk (cadr (memq '&cl-defs arg)))
 	       (setq arg (delq '&cl-defs (delq junk arg))))
 	       (setq arg (delq '&cl-quote arg)))
 	   (mapcar 'cl-upcase-arg arg)))
 	(t arg)))                         ; Maybe we are in initializer
 ;; npak@ispras.ru
+;;;###autoload
 (defun cl-function-arglist (name arglist)
 "Returns string with printed representation of arguments list.
 Supports Common Lisp lambda lists."
 (if (not (or (listp arglist) (symbolp arglist)))
 "Not available"
-(setq arglist-visited nil)
+(check-argument-type #'true-list-p arglist)
-(condition-case nil
+(let ((print-gensym nil))
-	(prin1-to-string
+(condition-case nil
-	 (cons (if (eq name 'cl-none) 'lambda name)
+(prin1-to-string
-	       (cond ((null arglist) nil)
+(cons (if (eq name 'cl-none) 'lambda name)
-		     ((listp arglist) (cl-upcase-arg arglist))
+(cond ((null arglist) nil)
-		     ((symbolp arglist)
+((listp arglist) (cl-upcase-arg arglist))
-		      (cl-upcase-arg (list '&rest arglist)))
+((symbolp arglist)
-		     (t (wrong-type-argument 'listp arglist)))))
+(cl-upcase-arg (list '&rest arglist)))
-(t "Not available"))))
+(t (wrong-type-argument 'listp arglist)))))
+(t "Not available")))))
 (defun cl-transform-lambda (form bind-block)
 (let* ((args (car form)) (body (cdr form))
 	 (bind-defs nil) (bind-enquote nil)
 	 (bind-inits nil) (bind-lets nil) (bind-forms nil)
 	 (header nil) (simple-args nil)
+(complex-arglist (cl-function-arglist bind-block args))
 (doc ""))
-;; Add CL lambda list to documentation. npak@ispras.ru
-(if (and (stringp (car body))
-	     (cdr body))
-(setq doc (pop body)))
-(push (concat doc
-		  "\nCommon Lisp lambda list:\n"
-		  "  " (cl-function-arglist bind-block args)
-		  "\n\n")
-	  header)
 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
 (push (pop body) header))
 (setq args (if (listp args) (copy-list args) (list '&rest args)))
 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
 (if (setq bind-defs (cadr (memq '&cl-defs args)))
 		(not (and (eq (car args) '&optional)
 			  (or bind-defs (consp (cadr args))))))
 (push (pop args) simple-args))
 (or (eq bind-block 'cl-none)
 	(setq body (list (list* 'block bind-block body))))
+(setq simple-args (nreverse simple-args)
+header (nreverse header))
+;; Add CL lambda list to documentation, if the CL lambda list differs
+;; from the non-CL lambda list. npak@ispras.ru
+(unless (equal complex-arglist
+(cl-function-arglist bind-block simple-args))
+(and (stringp (car header)) (setq doc (pop header)))
+(push (concat doc
+"\n\nCommon Lisp lambda list:\n"
+"  " complex-arglist "\n\n")
+	  header))
 (if (null args)
-	(list* nil (nreverse simple-args) (nconc (nreverse header) body))
+	(list* nil simple-args (nconc header body))
 (if (memq '&optional simple-args) (push '&optional args))
 (cl-do-arglist args nil (- (length simple-args)
 				 (if (memq '&optional simple-args) 1 0)))
 (setq bind-lets (nreverse bind-lets))
 (list* (and bind-inits (list* 'eval-when '(compile load eval)
 				    (nreverse bind-inits)))
-	     (nconc (nreverse simple-args)
+	     (nconc simple-args
 		    (list '&rest (car (pop bind-lets))))
 	     ;; XEmacs change: we add usage information using Nickolay's
 	     ;; approach above
-	     (nconc (nreverse header)
+	     (nconc header
 		    (list (nconc (list 'let* bind-lets)
 				 (nreverse bind-forms) body)))))))
 (defun cl-do-arglist (args expr &optional num)   ; uses bind-*
 (if (nlistp args)
 ;;; Conditional control structures.
 ;;;###autoload
 (defmacro case (expr &rest clauses)
-"(case EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value.
+"Evals EXPR, chooses from CLAUSES on that value.
 Each clause looks like (KEYLIST BODY...).  EXPR is evaluated and compared
 against each key in each KEYLIST; the corresponding BODY is evaluated.
 If no clause succeeds, case returns nil.  A single atom may be used in
 place of a KEYLIST of one atom.  A KEYLIST of `t' or `otherwise' is
 allowed only in the final clause, and matches if no other keys match.
 ;; anything to introduce it, as there is probably much more CL stuff
 ;; missing, and the feature is not essential.  --hniksic
 ;;;###autoload
 (defmacro ecase (expr &rest clauses)
-"(ecase EXPR CLAUSES...): like `case', but error if no case fits.
+"Like `case', but error if no case fits.
 `otherwise'-clauses are not allowed."
 ;; XEmacs addition: disallow t and otherwise
 (let ((disallowed (or (assq t clauses)
 			(assq 'otherwise clauses))))
 (if disallowed
 	(error "`%s' is not allowed in ecase" (car disallowed))))
 (list* 'case expr (append clauses '((ecase-error-flag)))))
 ;;;###autoload
 (defmacro typecase (expr &rest clauses)
-"(typecase EXPR CLAUSES...): evals EXPR, chooses from CLAUSES on that value.
+"Evals EXPR, chooses from CLAUSES on that value.
 Each clause looks like (TYPE BODY...).  EXPR is evaluated and, if it
 satisfies TYPE, the corresponding BODY is evaluated.  If no clause succeeds,
 typecase returns nil.  A TYPE of `t' or `otherwise' is allowed only in the
 final clause, and matches if no other keys match."
 (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym)))
 (if (eq temp expr) body
 (list 'let (list (list temp expr)) body))))
 ;;;###autoload
 (defmacro etypecase (expr &rest clauses)
-"(etypecase EXPR CLAUSES...): like `typecase', but error if no case fits.
+"Like `typecase', but error if no case fits.
 `otherwise'-clauses are not allowed."
 (list* 'typecase expr (append clauses '((ecase-error-flag)))))
 ;;; Blocks and exits.
 ;;;###autoload
 (defmacro block (name &rest body)
-"(block NAME BODY...): define a lexically-scoped block named NAME.
+"Define a lexically-scoped block named NAME.
 NAME may be any symbol.  Code inside the BODY forms can call `return-from'
 to jump prematurely out of the block.  This differs from `catch' and `throw'
 in two respects:  First, the NAME is an unevaluated symbol rather than a
 quoted symbol or other form; and second, NAME is lexically rather than
 dynamically scoped:  Only references to it within BODY will work.  These
 	  (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
 		 body))))
 (defvar cl-active-block-names nil)
-(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
+(put 'cl-block-wrapper 'byte-compile
-(defun cl-byte-compile-block (cl-form)
+#'(lambda (cl-form)
-(if (fboundp 'byte-compile-form-do-effect)  ; Check for optimizing compiler
+(if (/= (length cl-form) 2)
-(progn
+(byte-compile-warn-wrong-args cl-form 1))
-	(let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
-	       (cl-active-block-names (cons cl-entry cl-active-block-names))
+(if (fboundp 'byte-compile-form-do-effect)  ; Check for optimizing
-	       (cl-body (byte-compile-top-level
+						     ; compiler
-			 (cons 'progn (cddr (nth 1 cl-form))))))
+(progn
-	  (if (cdr cl-entry)
+(let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
-	      (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
+(cl-active-block-names (cons cl-entry
-	    (byte-compile-form cl-body))))
+cl-active-block-names))
-(byte-compile-form (nth 1 cl-form))))
+(cl-body (byte-compile-top-level
+(cons 'progn (cddr (nth 1 cl-form))))))
-(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
+(if (cdr cl-entry)
-(defun cl-byte-compile-throw (cl-form)
+(byte-compile-form (list 'catch (nth 1 (nth 1 cl-form))
-(let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
+cl-body))
-(if cl-found (setcdr cl-found t)))
+(byte-compile-form cl-body))))
-(byte-compile-normal-call (cons 'throw (cdr cl-form))))
+(byte-compile-form (nth 1 cl-form)))))
+(put 'cl-block-throw 'byte-compile
+#'(lambda (cl-form)
+(let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
+(if cl-found (setcdr cl-found t)))
+(byte-compile-throw (cons 'throw (cdr cl-form)))))
 ;;;###autoload
 (defmacro return (&optional result)
-"(return [RESULT]): return from the block named nil.
+"Return from the block named nil.
 This is equivalent to `(return-from nil RESULT)'."
 (list 'return-from nil result))
 ;;;###autoload
 (defmacro return-from (name &optional result)
-"(return-from NAME [RESULT]): return from the block named NAME.
+"Return from the block named NAME.
 This jumps out to the innermost enclosing `(block NAME ...)' form,
 returning RESULT from that form (or nil if RESULT is omitted).
 This is compatible with Common Lisp, but note that `defun' and
 `defmacro' do not create implicit blocks as they do in Common Lisp."
 (let ((name2 (intern (format "--cl-block-%s--" name))))
 ;;; Binding control structures.
 ;;;###autoload
 (defmacro progv (symbols values &rest body)
-"(progv SYMBOLS VALUES BODY...): bind SYMBOLS to VALUES dynamically in BODY.
+"Bind SYMBOLS to VALUES dynamically in BODY.
 The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists.
 Each SYMBOL in the first list is bound to the corresponding VALUE in the
 second list (or made unbound if VALUES is shorter than SYMBOLS); then the
 BODY forms are executed and their result is returned.  This is much like
 a `let' form, except that the list of symbols can be computed at run-time."
 				cl-macro-environment)))))
 (defvar cl-closure-vars nil)
 ;;;###autoload
 (defmacro lexical-let (bindings &rest body)
-"(lexical-let BINDINGS BODY...): like `let', but lexically scoped.
+"Like `let', but lexically scoped.
 The main visible difference is that lambdas inside BODY will create
 lexical closures as in Common Lisp."
 (let* ((cl-closure-vars cl-closure-vars)
 	 (vars (mapcar #'(lambda (x)
 			   (or (consp x) (setq x (list x)))
 			   vars))
 	    ebody))))
 ;;;###autoload
 (defmacro lexical-let* (bindings &rest body)
-"(lexical-let* BINDINGS BODY...): like `let*', but lexically scoped.
+"Like `let*', but lexically scoped.
 The main visible difference is that lambdas inside BODY will create
 lexical closures as in Common Lisp."
 (if (null bindings) (cons 'progn body)
 (setq bindings (reverse bindings))
 (while bindings
 (list 'progn
 	(list 'defalias (list 'quote func)
 	      (list 'function (cons 'lambda rest)))
 	(list 'quote func)))
+;;; Multiple values. We support full Common Lisp conventions here.
-;;; Multiple values.
+;;;###autoload
-;;;###autoload
+(defmacro multiple-value-bind (syms form &rest body)
-(defmacro multiple-value-bind (vars form &rest body)
+"Collect and bind multiple return values.
-"(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values.
-FORM must return a list; the BODY is then executed with the first N elements
+If FORM returns multiple values, each symbol in SYMS is bound to one of
-of this list bound (`let'-style) to each of the symbols SYM in turn.  This
+them, in order, and BODY is executed.  If FORM returns fewer multiple values
-is analogous to the Common Lisp `multiple-value-bind' macro, using lists to
+than there are SYMS, remaining SYMS are bound to nil.  If FORM does
-simulate true multiple return values.  For compatibility, (values A B C) is
+not return multiple values, it is treated as returning one multiple value.
-a synonym for (list A B C)."
-(let ((temp (gensym)) (n -1))
+Returns the value given by the last element of BODY."
-(list* 'let* (cons (list temp form)
+(if (null syms)
-		       (mapcar #'(lambda (v)
+`(progn ,form ,@body)
-				   (list v (list 'nth (setq n (1+ n)) temp)))
+(if (= 1 (length syms))
-			       vars))
+;; Code written to deal with other "implementations" of multiple
-	   body)))
+;; values may have a one-element SYMS.
+`(let ((,(car syms) ,form))
-;;;###autoload
+,@body)
-(defmacro multiple-value-setq (vars form)
+(let ((temp (gensym)))
-"(multiple-value-setq (SYM SYM...) FORM): collect multiple return values.
+`(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form))
-FORM must return a list; the first N elements of this list are stored in
+,@(loop
-each of the symbols SYM in turn.  This is analogous to the Common Lisp
+for var in syms
-`multiple-value-setq' macro, using lists to simulate true multiple return
+collect `(,var (prog1 (car ,temp)
-values.  For compatibility, (values A B C) is a synonym for (list A B C)."
+(setq ,temp (cdr ,temp))))))
-(cond ((null vars) (list 'progn form nil))
+,@body)))))
-	((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
-	(t
+;;;###autoload
-	 (let* ((temp (gensym)) (n 0))
+(defmacro multiple-value-setq (syms form)
-	   (list 'let (list (list temp form))
+"Collect and set multiple values.
-		 (list 'prog1 (list 'setq (pop vars) (list 'car temp))
-		       (cons 'setq
+FORM should normally return multiple values; the first N values are stored
-			     (apply 'nconc
+in the symbols in SYMS in turn.  If FORM returns fewer than N values, the
-				    (mapcar
+remaining symbols have their values set to nil.  FORM not returning multiple
-				     #'(lambda (v)
+values is treated as FORM returning one multiple value, with other elements
-					 (list v (list
+of SYMS initialized to nil.
-						  'nth
-						  (setq n (1+ n))
+Returns the first of the multiple values given by FORM."
-						  temp)))
+(if (null syms)
-					    vars)))))))))
+;; Never return multiple values from multiple-value-setq:
+(and form `(values ,form))
+(if (= 1 (length syms))
+`(setq ,(car syms) ,form)
+(let ((temp (gensym)))
+`(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form)))
+(setq ,@(loop
+for sym in syms
+nconc `(,sym (car-safe ,temp)
+,temp (cdr-safe ,temp))))
+,(car syms))))))
+;;;###autoload
+(defmacro multiple-value-list (form)
+"Evaluate FORM and return a list of the multiple values it returned."
+`(multiple-value-list-internal 0 multiple-values-limit ,form))
+;;;###autoload
+(defmacro nth-value (n form)
+"Evaluate FORM and return the Nth multiple value it returned."
+(if (integerp n)
+`(car (multiple-value-list-internal ,n ,(1+ n) ,form))
+(let ((temp (gensym)))
+`(let ((,temp ,n))
+(car (multiple-value-list-internal ,temp (1+ ,temp) ,form))))))
 ;;; Declarations.
 ;;;###autoload
 (defmacro locally (&rest body) (cons 'progn body))
 			     (get-setf-method x cl-macro-environment))
 			 args))
 	(store-temp (gensym "--values-store--")))
 (list (apply 'append (mapcar 'first methods))
 	  (apply 'append (mapcar 'second methods))
-	  (list store-temp)
+	  `((,store-temp
-	  (cons 'list
+	     (multiple-value-list-internal 0 ,(if args (length args) 1))))
+	  (cons 'values
 		(mapcar #'(lambda (m)
 			    (cl-setf-do-store (cons (car (third m)) (fourth m))
 					      (list 'pop store-temp)))
 			methods))
 	  (cons 'list (mapcar 'fifth methods)))))
 	  (sublis subs (nth 4 method)))))
 (defun cl-setf-do-store (spec val)
 (let ((sym (car spec))
 	(form (cdr spec)))
-(if (or (cl-const-expr-p val)
+(if (consp sym)
-	    (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1))
+	;; XEmacs change, only used for implementing #'values at the moment.
-	    (cl-setf-simple-store-p sym form))
+	(let* ((orig (copy-list sym))
-	(subst val sym form)
+	       (intermediate (last orig))
-(list 'let (list (list sym val)) form))))
+	       (circular-limit 32))
+	  (while (consp (car intermediate))
+	    (when (zerop circular-limit)
+	      (error 'circular-list "Form seems to contain loops"))
+	    (setq intermediate (last (car intermediate))
+		  circular-limit (1- circular-limit)))
+	  (setcdr intermediate (list val))
+	  `(let (,orig)
+	    ,form))
+(if (or (cl-const-expr-p val)
+	      (and (cl-simple-expr-p val)
+		   (eq (cl-expr-contains form sym) 1))
+	      (cl-setf-simple-store-p sym form))
+	  (subst val sym form)
+	(list 'let (list (list sym val)) form)))))
 (defun cl-setf-simple-store-p (sym form)
 (and (consp form) (eq (cl-expr-contains form sym) 1)
 (eq (nth (1- (length form)) form) sym)
 (symbolp (car form)) (fboundp (car form))
 		  (list 'car temp)
 		  (cl-setf-do-store (nth 1 method) (list 'cdr temp)))))))
 ;;;###autoload
 (defmacro remf (place tag)
-"(remf PLACE TAG): remove TAG from property list PLACE.
+"Remove TAG from property list PLACE.
 PLACE may be a symbol, or any generalized variable allowed by `setf'.
 The form returns true if TAG was found and removed, nil otherwise."
 (let* ((method (cl-setf-do-modify place t))
 	 (tag-temp (and (not (cl-const-expr-p tag)) (gensym "--remf-tag--")))
 	 (val-temp (and (not (cl-simple-expr-p place))
 				 (cl-setf-do-store (nth 1 method) form))))))
 (let ((method (cl-setf-do-modify (car places) 'unsafe)))
 	(list 'let* (append (car method) (list (list temp (nth 2 method))))
 	      (cl-setf-do-store (nth 1 method) form) nil)))))
+;; This function is not in Common Lisp, and there are gaps in its structure and
+;; implementation that reflect that it was never well-specified. E.g. with
+;; setf, the question of whether a PLACE is bound or not and how to make it
+;; unbound doesn't arise, but we need some way of specifying that for letf to
+;; be sensible for gethash, symbol-value and so on; currently we just hard-code
+;; symbol-value, symbol-function and values (the latter is XEmacs work that
+;; I've just done) in the body of this function, and the following gives the
+;; wrong behaviour for gethash:
+;;
+;; (setq my-hash-table #s(hash-table test equal data ())
+;;       print-gensym t)
+;; => t
+;; (gethash "my-key" my-hash-table (gensym))
+;; => #:G68010
+;; (letf (((gethash "my-key" my-hash-table) 4000))
+;;   (message "key value is %S" (gethash "my-key" my-hash-table)))
+;; => "key value is 4000"
+;; (gethash "my-key" my-hash-table (gensym))
+;; => nil ;; should be an uninterned symbol.
+;;
+;; Aidan Kehoe, Fr Nov 13 16:12:21 GMT 2009
 ;;;###autoload
 (defmacro letf (bindings &rest body)
 "(letf ((PLACE VALUE) ...) BODY...): 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
 			  (list 'symbol-value (list 'quote (caar rev)))
 			(caar rev)))
 	       (value (cadar rev))
 	       (method (cl-setf-do-modify place 'no-opt))
 	       (save (gensym "--letf-save--"))
-	       (bound (and (memq (car place) '(symbol-value symbol-function))
+	       (bound (and (memq (car place)
+'(symbol-value symbol-function values))
 			   (gensym "--letf-bound--")))
 	       (temp (and (not (cl-const-expr-p value)) (cdr bindings)
-			  (gensym "--letf-val--"))))
+			  (gensym "--letf-val--")))
+(syms (and (eq 'values (car place))
+(gensym "--letf-syms--")))
+(cursor (and syms (gensym "--letf-cursor--"))))
 	  (setq lets (nconc (car method)
-			    (if bound
+(cond
-				(list (list bound
+(syms
-					    (list (if (eq (car place)
+`((,syms ',(loop
-							  'symbol-value)
+for sym in (cdr place)
-						      'boundp 'fboundp)
+nconc (if (symbolp sym) (list sym))))
-						  (nth 1 (nth 2 method))))
+(,cursor ,syms)
-				      (list save (list 'and bound
+(,bound nil)
-						       (nth 2 method))))
+(,save
-			      (list (list save (nth 2 method))))
+(prog2
+(while (consp ,cursor)
+(setq ,bound
+(cons (and (boundp (car ,cursor))
+(symbol-value
+(car ,cursor)))
+,bound)
+,cursor (cdr ,cursor)))
+;; Just using ,bound as a temporary
+;; variable here, to initialise ,save:
+(nreverse ,bound)
+;; Now, really initialise ,bound:
+(setq ,cursor ,syms
+,bound nil
+,bound
+(progn (while (consp ,cursor)
+(setq ,bound
+(cons
+(boundp (car ,cursor))
+,bound)
+,cursor (cdr ,cursor)))
+(nreverse ,bound)))))))
+(bound
+(list (list bound
+(list (if (eq (car place)
+'symbol-value)
+'boundp 'fboundp)
+(nth 1 (nth 2 method))))
+(list save (list 'and bound
+(nth 2 method)))))
+(t
+(list (list save (nth 2 method)))))
 			    (and temp (list (list temp value)))
 			    lets)
 		body (list
 		      (list 'unwind-protect
 			    (cons 'progn
 				  (if (cdr (car rev))
 				      (cons (cl-setf-do-store (nth 1 method)
 							      (or temp value))
 					    body)
 				    body))
-			    (if bound
+(cond
-				(list 'if bound
+(syms
-				      (cl-setf-do-store (nth 1 method) save)
+`(while (consp ,syms)
-				      (list (if (eq (car place) 'symbol-value)
+(if (car ,bound)
-						'makunbound 'fmakunbound)
+(set (car ,syms) (car ,save))
-					    (nth 1 (nth 2 method))))
+(makunbound (car ,syms)))
-			      (cl-setf-do-store (nth 1 method) save))))
+(setq ,syms (cdr ,syms)
+,bound (cdr ,bound)
+,save (cdr ,save))))
+(bound
+(list 'if bound
+(cl-setf-do-store (nth 1 method) save)
+(list (if (eq (car place)
+'symbol-function)
+'fmakunbound
+'makunbound)
+(nth 1 (nth 2 method)))))
+(t
+			      (cl-setf-do-store (nth 1 method) save)))))
 		rev (cdr rev))))
 (list* 'let* lets body))))
 ;;;###autoload
 (defmacro letf* (bindings &rest body)
 (setq body (list (list* 'letf (list (pop bindings)) body))))
 (car body)))
 ;;;###autoload
 (defmacro callf (func place &rest args)
-"(callf FUNC PLACE ARGS...): set PLACE to (FUNC PLACE ARGS...).
+"Set PLACE to (FUNC PLACE ARGS...).
 FUNC should be an unquoted function name.  PLACE may be a symbol,
 or any generalized variable allowed by `setf'."
 (let* ((method (cl-setf-do-modify place (cons 'list args)))
 	 (rargs (cons (nth 2 method) args)))
 (list 'let* (car method)
 			      (list* 'funcall (list 'function func)
 				     rargs))))))
 ;;;###autoload
 (defmacro callf2 (func arg1 place &rest args)
-"(callf2 FUNC ARG1 PLACE ARGS...): set PLACE to (FUNC ARG1 PLACE ARGS...).
+"Set PLACE to (FUNC ARG1 PLACE ARGS...).
 Like `callf', but PLACE is the second argument of FUNC, not the first."
 (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
 (list 'setf place (list* func arg1 place args))
 (let* ((method (cl-setf-do-modify place (cons 'list args)))
 	   (temp (and (not (cl-const-expr-p arg1)) (gensym "--arg1--")))
 				(list* 'funcall (list 'function func)
 				       rargs)))))))
 ;;;###autoload
 (defmacro define-modify-macro (name arglist func &optional doc)
-"(define-modify-macro NAME ARGLIST FUNC): define a `setf'-like modify macro.
+"Define a `setf'-like modify macro.
 If NAME is called, it combines its PLACE argument with the other arguments
 from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
 (if (memq '&key arglist) (error "&key not allowed in define-modify-macro"))
 (let ((place (gensym "--place--")))
 (list 'defmacro* name (cons place arglist) doc
 ;;; Types and assertions.
 ;;;###autoload
 (defmacro deftype (name arglist &rest body)
-"(deftype NAME ARGLIST BODY...): define NAME as a new data type.
+"Define NAME as a new data type.
 The type name can then be used in `typecase', `check-type', etc."
 (list 'eval-when '(compile load eval)
 	(cl-transform-function-property
 	 name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) arglist) body))))
 ;;; Compiler macros.
 ;;;###autoload
 (defmacro define-compiler-macro (func args &rest body)
-"(define-compiler-macro FUNC ARGLIST BODY...): Define a compiler-only macro.
+"Define a compiler-only macro.
 This is like `defmacro', but macro expansion occurs only if the call to
 FUNC is compiled (i.e., not interpreted).  Compiler macros should be used
 for optimizing the way calls to FUNC are compiled; the form returned by
 BODY should do the same thing as a call to the normal function called
 FUNC, though possibly more efficiently.  Note that, like regular macros,
 		(cl-simple-expr-p val)) res
 	  (let ((temp (gensym)))
 	    (list 'let (list (list temp val)) (subst temp val res)))))
 form))
+;; XEmacs; inline delete-duplicates if it's called with a literal
+;; #'equal or #'eq and no other keywords, we want the speed in
+;; font-lock.el.
+(define-compiler-macro delete-duplicates (&whole form cl-seq &rest cl-keys)
+(let ((listp-check
+(if (memq (car-safe cl-seq)
+;; No need to check for a list at runtime with these. We
+;; could expand the list, but these are all the functions
+;; in the relevant context at the moment.
+'(nreverse append nconc mapcan mapcar))
+t
+'(listp begin))))
+(cond ((and (= 4 (length form))
+(eq :test (third form))
+(or (equal '(quote eq) (fourth form))
+(equal '(function eq) (fourth form))))
+`(let* ((begin ,cl-seq)
+(cl-seq begin))
+(if ,listp-check
+(progn
+(while cl-seq
+(setq cl-seq (setcdr cl-seq (delq (car cl-seq)
+(cdr cl-seq)))))
+begin)
+;; Call cl-delete-duplicates explicitly, to avoid the form
+;; getting compiler-macroexpanded again:
+(cl-delete-duplicates begin ',cl-keys nil))))
+((and (= 4 (length form))
+(eq :test (third form))
+(or (equal '(quote equal) (fourth form))
+(equal '(function equal) (fourth form))))
+`(let* ((begin ,cl-seq)
+(cl-seq begin))
+(if ,listp-check
+(progn
+(while cl-seq
+(setq cl-seq (setcdr cl-seq (delete (car cl-seq)
+(cdr cl-seq)))))
+begin)
+;; Call cl-delete-duplicates explicitly, to avoid the form
+;; getting compiler-macroexpanded again:
+(cl-delete-duplicates begin ',cl-keys nil))))
+(t
+form))))
+;; XEmacs change, the GNU mapc doesn't accept the Common Lisp args, so this
+;; change isn't helpful.
+(define-compiler-macro mapc (&whole form cl-func cl-seq &rest cl-rest)
+(if cl-rest
+form
+(cons 'mapc-internal (cdr form))))
+(define-compiler-macro mapcar* (&whole form cl-func cl-x &rest cl-rest)
+(if cl-rest
+form
+(cons 'mapcar (cdr form))))
+;; XEmacs; it's perfectly reasonable, and often much clearer to those
+;; reading the code, to call regexp-quote on a constant string, which is
+;; something we can optimise here easily.
+(define-compiler-macro regexp-quote (&whole form string)
+(if (stringp string)
+(regexp-quote string)
+form))
 (mapc
 #'(lambda (y)
 (put (car y) 'side-effect-free t)
 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)

Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5118:e0db3c197671 ben-lisp-object