Commits

Stephen Turnbull committed f45338d Merge

Merge in my release prep stuff.

Comments (0)

Files changed (61)

+2012-05-14  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* byte-optimize.el (byte-optimize-letX):
+	In (let ...) forms, group constant initialisations together, so we
+	can just dup in the byte code.
+
+2012-05-14  Aidan Kehoe  <kehoea@parhasard.net>
+
+	Update minibuf.el to use #'test-completion, use the generality of
+	recent completion changes to avoid some unnecessary consing when
+	reading.
+	* behavior.el (read-behavior):
+	* cus-edit.el (custom-face-prompt):
+	* cus-edit.el (widget-face-action):
+	* faces.el (read-face-name):
+	* minibuf.el:
+	* minibuf.el (minibuffer-completion-table):
+	* minibuf.el (exact-minibuffer-completion-p):
+	Removed. #'test-completion is equivalent to this, but more
+	general.
+	* minibuf.el (minibuffer-do-completion-1): Use #'test-completion.
+	* minibuf.el (completing-read): Update the documentation of the
+	arguments used for completion.
+	* minibuf.el (minibuffer-complete-and-exit): Use #'test-completion.
+	* minibuf.el (exit-minibuffer): Use #'test-completion.
+	* minibuf.el (minibuffer-smart-mouse-tracker): Use #'test-completion.
+	* minibuf.el (read-color): No need to construct a completion table
+	separate from the colour list.
+
+2012-05-12  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* subr.el:
+	* subr.el (truncate-string-to-width):
+	Sync with GNU's version, use its test suite in mule-tests.el.
+	Avoid args-out-of-range errors, this function is regularly called
+	from menu code and with debug-on-signal non-nil, this can be very
+	irritating.
+	Don't bind ellipsis-len, we don't use it.
+
+2012-05-12  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* byte-optimize.el (byte-compile-unfold-lambda):
+	Fetch the bytecode before unfolding a compiled function, its body
+	may have been compiled lazily thanks to
+	byte-compile-dynamic. Thank you Mats Lidell and the package
+	smoketest!
+
+2012-05-10  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* mule/mule-category.el (word-combining-categories):
+	Be better about default word boundaries when text contains
+	just-in-time-allocated Unicode code points. Document what we
+	should do instead once we have Unicode internally.
+	* mule/misc-lang.el: IPA characters are Latin.
+
+2012-05-08  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* cl-macs.el (rassoc): Remove a stray parenthesis here, thank you
+	Vin!
+
+2012-05-06  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* cl-macs.el (block): Comment on why we can't use &environment
+	here.
+	* cl-macs.el (defmacro*): Document &environment in more detail.
+	* cl-macs.el (macrolet): Use &environment, instead of referencing
+	byte-compile-macro-environment directly.
+	* cl-macs.el (symbol-macrolet): Ditto.
+	* cl-macs.el (lexical-let): Ditto.
+	* cl-macs.el (labels): Ditto.
+
+2012-05-06  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* byte-optimize.el:
+	* byte-optimize.el (or):
+	* byte-optimize.el (byte-optimize-or):
+	Declare for-effect properly, it's not free.
+	* byte-optimize.el (byte-optimize-condition-case): New.
+	* byte-optimize.el (byte-optimize-form-code-walker):
+	Be more exhaustive in descending special forms, for the sake of
+	lexically-oriented optimizers such as that for #'labels.
+
+2012-05-05  Aidan Kehoe  <kehoea@parhasard.net>
+
+	Co-operate with the byte-optimizer in the bytecomp.el labels
+	implementation, don't work against it.
+
+	* byte-optimize.el:
+	* byte-optimize.el (byte-compile-inline-expand):
+	Call #'byte-compile-unfold-lambda explicitly here, don't assume
+	that the byte-optimizer will do it.
+	* byte-optimize.el (byte-compile-unfold-lambda):
+	Call #'byte-optimize-body on the body, don't just mapcar
+	#'byte-optimize-form along it.
+	* byte-optimize.el (byte-optimize-lambda): New. Optimize a lambda
+	form. 
+	* byte-optimize.el (byte-optimize-form-code-walker):
+	Descend lambda expressions, defun, and defmacro, relevant for
+	lexically-oriented operators like #'labels.
+	* byte-optimize.el (byte-optimize-body): Only return a non-eq
+	object if we've actually optimized something
+	* bytecomp.el (byte-compile-initial-macro-environment):
+	In the labels implementation, work with the byte optimizer, not
+	against it; warn when labels are defined but not used,
+	automatically inline labels that are used only once.
+	* bytecomp.el (byte-recompile-directory):
+	No need to wrap #'byte-compile-report-error in a lambda with
+	#'call-with-condition-handler here. 
+	* bytecomp.el (byte-compile-form):
+	Don't inline compiled-function objects, they're probably labels.
+	* bytecomp.el (byte-compile-funcall):
+	No longer inline lambdas, trust the byte optimizer to have done it
+	properly, even for labels.
+	* cl-extra.el (cl-macroexpand-all):
+	Treat labels established by the byte compiler distinctly from
+	those established by cl-macs.el.
+	* cl-macs.el (cl-do-proclaim):
+	Treat labels established by the byte compiler distinctly from
+	those established by cl-macs.el.
+	* gui.el (make-gui-button):
+	When referring to the #'gui-button-action label, quote it using
+	function, otherwise there's a warning from the byte compiler.
+
+2012-05-05  Aidan Kehoe  <kehoea@parhasard.net>
+
+	Remove some redundant functions; turn other utility functions into
+	labels, avoiding visibility in the global namespace, and reducing
+	the size of the dumped binary.
+
+	* auto-save.el (auto-save-unhex): Removed.
+	* auto-save.el (auto-save-unescape-name): Use #'string-to-number
+	instead of #'auto-save-unhex.
+	* files.el (save-some-buffers):
+	* files.el (save-some-buffers-1): Changed to a label.
+	* files.el (not-modified):
+	* gui.el (make-gui-button):
+	* gui.el (gui-button-action): Changed to a label.
+	* gui.el (insert-gui-button):
+	* indent.el (indent-for-tab-command):
+	* indent.el (insert-tab): Changed to a label.
+	* indent.el (indent-rigidly):
+	* isearch-mode.el:
+	* isearch-mode.el (isearch-ring-adjust):
+	* isearch-mode.el (isearch-ring-adjust1): Changed to a label.
+	* isearch-mode.el (isearch-pre-command-hook):
+	* isearch-mode.el (isearch-maybe-frob-keyboard-macros): Changed to
+	a label.
+	* isearch-mode.el (isearch-highlight):
+	* isearch-mode.el (isearch-make-extent): Changed to a label.
+	* itimer.el:
+	* itimer.el (itimer-decrement): Removed, replaced uses with decf.
+	* itimer.el (itimer-increment): Removed, replaced uses with incf.
+	* itimer.el (itimer-signum): Removed, replaced uses with minusp, plusp.
+	* itimer.el (itimer-name):
+	* itimer.el (check-itimer): Removed, replaced with #'check-type calls.
+	* itimer.el (itimer-value):
+	* itimer.el (check-itimer-coerce-string): Removed.
+	* itimer.el (itimer-restart):
+	* itimer.el (itimer-function):
+	* itimer.el (check-nonnegative-number): Removed.
+	* itimer.el (itimer-uses-arguments):
+	* itimer.el (check-string): Removed.
+	* itimer.el (itimer-function-arguments):
+	* itimer.el (itimer-recorded-run-time):
+	* itimer.el (set-itimer-name):
+	* itimer.el (set-itimer-value):
+	* itimer.el (set-itimer-value-internal):
+	* itimer.el (set-itimer-restart):
+	* itimer.el (set-itimer-function):
+	* itimer.el (set-itimer-is-idle):
+	* itimer.el (set-itimer-recorded-run-time):
+	* itimer.el (get-itimer):
+	* itimer.el (delete-itimer):
+	* itimer.el (start-itimer):
+	* itimer.el (activate-itimer):
+	* itimer.el (itimer-edit-set-field):
+	* itimer.el (itimer-edit-next-field):
+	* itimer.el (itimer-edit-previous-field):
+	Use incf, decf, plusp, minusp and the more general argument type
+	checking macros.
+	* lib-complete.el:
+	* lib-complete.el (lib-complete:better-root): Changed to a label.
+	* lib-complete.el (lib-complete:get-completion-table): Changed to
+	a label.
+	* lib-complete.el (read-library-internal): Include labels.
+	* lib-complete.el (lib-complete:cache-completions): Changed to a
+	label.
+	* minibuf.el (read-buffer): Use #'set-difference, don't reinvent it.
+	* newcomment.el (comment-padright): Use a label instead of
+	repeating a lambda expression.
+	* packages.el (package-get-key):
+	* packages.el (package-get-key-1): Removed, use #'getf instead.
+	* simple.el (kill-backward-chars): Removed; this isn't used.
+	* simple.el (what-cursor-position):
+	(lambda (arg) (format "%S" arg) -> #'prin1-to-string. 
+	* simple.el (debug-print-1): Renamed to #'debug-print.
+	* simple.el (debug-print): Removed, #'debug-print-1 was equivalent.
+	* subr.el (integer-to-bit-vector): check-nonnegative-number no
+	longer available.
+	* widget.el (define-widget):
+	* widget.el (define-widget-keywords): Removed, this was long obsolete.
+
+2012-05-01  Aidan Kehoe  <kehoea@parhasard.net>
+
+	Avoid #'delq in core code, for the sake of style and a (very
+	slightly) smaller binary.
+
+	* behavior.el (disable-behavior):
+	* behavior.el (compute-behavior-group-children):
+	* buff-menu.el (buffers-tab-items):
+	* byte-optimize.el (byte-optimize-delay-constants-math):
+	* byte-optimize.el (byte-optimize-logmumble):
+	* byte-optimize.el (byte-decompile-bytecode-1):
+	* byte-optimize.el (byte-optimize-lapcode):
+	* bytecomp.el:
+	* bytecomp.el (byte-compile-arglist-warn):
+	* bytecomp.el (byte-compile-warn-about-unresolved-functions):
+	* bytecomp.el (byte-compile-lambda):
+	* bytecomp.el (byte-compile-out-toplevel):
+	* bytecomp.el (byte-compile-insert):
+	* bytecomp.el (byte-compile-defalias-warn):
+	* cl-macs.el (cl-upcase-arg):
+	* cl-macs.el (cl-transform-lambda):
+	* cl-macs.el (cl-do-proclaim):
+	* cl-macs.el (defstruct):
+	* cl-macs.el (cl-make-type-test):
+	* cl-macs.el (define-compiler-macro):
+	* cl-macs.el (delete-duplicates):
+	* cus-edit.el (widget-face-value-delete):
+	* cus-edit.el (face-history):
+	* easymenu.el (easy-menu-remove):
+	* files.el (files-fetch-hook-value):
+	* files.el (file-expand-wildcards):
+	* font-lock.el (font-lock-update-removed-keyword-alist):
+	* font-lock.el (font-lock-remove-keywords):
+	* frame.el (frame-initialize):
+	* frame.el (frame-notice-user-settings):
+	* frame.el (set-frame-font):
+	* frame.el (delete-other-frames):
+	* frame.el (get-frame-for-buffer-noselect):
+	* gnuserv.el (gnuserv-kill-buffer-function):
+	* gnuserv.el (gnuserv-check-device):
+	* gnuserv.el (gnuserv-kill-client):
+	* gnuserv.el (gnuserv-buffer-done-1):
+	* gtk-font-menu.el (gtk-reset-device-font-menus):
+	* gutter-items.el (buffers-tab-items):
+	* gutter.el (set-gutter-element-visible-p):
+	* info.el (Info-find-file-node):
+	* info.el (Info-history-add):
+	* info.el (Info-build-annotation-completions):
+	* info.el (Info-index):
+	* info.el (Info-reannotate-node):
+	* itimer.el (delete-itimer):
+	* itimer.el (start-itimer):
+	* lib-complete.el (lib-complete:cache-completions):
+	* loadhist.el (unload-feature):
+	* menubar-items.el (build-buffers-menu-internal):
+	* menubar.el (delete-menu-item):
+	* menubar.el (relabel-menu-item):
+	* msw-font-menu.el (mswindows-reset-device-font-menus):
+	* mule/make-coding-system.el (fixed-width-generate-helper):
+	* next-error.el (next-error-find-buffer):
+	* obsolete.el:
+	* obsolete.el (find-non-ascii-charset-string):
+	* obsolete.el (find-non-ascii-charset-region):
+	* occur.el (multi-occur-by-filename-regexp):
+	* occur.el (occur-1):
+	* packages.el (packages-package-hierarchy-directory-names):
+	* packages.el (package-get-key-1):
+	* process.el (setenv):
+	* simple.el (undo):
+	* simple.el (handle-pre-motion-command-current-command-is-motion):
+	* sound.el (load-sound-file):
+	* wid-edit.el (widget-field-value-delete):
+	* wid-edit.el (widget-checklist-match-inline):
+	* wid-edit.el (widget-checklist-match-find):
+	* wid-edit.el (widget-editable-list-delete-at):
+	* wid-edit.el (widget-editable-list-entry-create):
+	* window.el (quit-window):
+	* x-font-menu.el (x-reset-device-font-menus-core):
+
+	1. Replace (delq nil (mapcar ....)) with analogous (mapcan ...)
+	forms; this is in non-dumped files, it was done previously in
+	dumped files.
+	2. Replace (delq FOO (copy-sequence BAR)) with (remove* FOO BAR),
+	where #'eq and #'eql are equivalent
+	3. Replace (delq FOO BAR) with (delete* FOO BAR), where FOO is not
+	a non-fixnum number. Saves a little space in the dumped file
+	(since the compiler macro adds :test #'eq to the delete* call if
+	it's not clear that FOO is not a non-fixnum number).
+
+2012-05-07  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* cl-macs.el:
+	* cl-macs.el (cl-non-fixnum-number-p): Rename, to
+	cl-non-immediate-number-p. This is a little more informative as a
+	name, though still not ideal, in that it will give t for some
+	immediate fixnums on 64-bit builds.
+	* cl-macs.el (eql):
+	* cl-macs.el (define-star-compiler-macros):
+	* cl-macs.el (delq):
+	* cl-macs.el (remq):
+	Use the new name.
+	* cl-macs.el (cl-equal-equivalent-to-eq-p): New.
+	* cl-macs.el (cl-car-or-pi): New.
+	* cl-macs.el (cl-cdr-or-pi): New.
+	* cl-macs.el (equal): New compiler macro.
+	* cl-macs.el (member): New compiler macro.
+	* cl-macs.el (assoc): New compiler macro.
+	* cl-macs.el (rassoc): New compiler macro.
+	If any of #'equal, #'member, #'assoc or #'rassoc has a constant
+	argument such that #'eq, #'memq, #'assq or #'rassq, respectively,
+	are equivalent, make the substitution. Relevant in files like
+	ispell.el, there's a reasonable amount of code out there that
+	doesn't quite get the distinction.
+
+2012-05-01  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* byte-optimize.el (byte-optimize-form-code-walker):
+	* byte-optimize.el (byte-optimize-or):
+	Improve handling of for-effect here; we don't need to worry about
+	discarding multiple values when for-effect is non-nil, this
+	applies to both #'prog1 and #'or.
+	* bytecomp.el (progn):
+	* bytecomp.el (byte-compile-file-form-progn): New.
+	Put back this function, since it's for-effect there's no need to
+	worry about passing back multiple values.
+	* cl-macs.el (cl-pop2):
+	* cl-macs.el (cl-do-pop):
+	* cl-macs.el (remf):
+	* cl.el (pop):
+	Expand to (prog1 (car-safe PLACE) (setq PLACE (cdr PLACE))) in all
+	these macros, since that optimizes better (especially for-effect
+	handling) when byte-compile-delete-errors is nil.
+
+2012-04-23  Michael Sperber  <mike@xemacs.org>
+
+	* bytecomp.el (batch-byte-recompile-directory): Accept an optional
+	argument that's passed on to `byte-recompile-directory' as the
+	prefix argument, thus imitating GNU Emacs's API.
+
+2012-04-07  Aidan Kehoe  <kehoea@parhasard.net>
+
+	Remove some utility functions from the global namespace, it's more
+	appropriate to have them as labels (that is, lexically-visible
+	functions.) 
+	* behavior.el:
+	* behavior.el (behavior-menu-filter-1): Moved to being a label.
+	* behavior.el (behavior-menu-filter): Use the label.
+	* cus-edit.el (custom-load-symbol-1): Moved to being a label.
+	* cus-edit.el (custom-load-symbol): Use the label.
+	* menubar.el (find-menu-item-1): Moved to being a label.
+	* menubar.el (find-menu-item): Use the label.
+	* window-xemacs.el:
+	* window-xemacs.el (display-buffer-1): Moved to being a label.
+	* window-xemacs.el (display-buffer): Use the label; use (block
+	...) instead of (catch ...), use prog1 instead of needlessly
+	binding a variable.
+
 2012-03-02  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* select.el (select-coerce):
 	Bind print-gensym-alist to nil, as we do within
 	byte-compile-output-docform.
 
+2008-01-03  Michael Sperber  <mike@xemacs.org>
+
+	* files.el (file-remote-p): Synch with GNU Emac: Add
+	`identification' and `connected' parameters, and use file-name
+	handler if available.  Zap support for ange-ftp.
+
 2008-01-04  Michael Sperber  <mike@xemacs.org>
 
 	* code-files.el (insert-file-contents):

lisp/auto-save.el

 	(char-to-string char))))
    str ""))
 
-(defun auto-save-unhex (x)
-  (if (> x ?9)
-      (if (>= x ?a)
-	  (+ 10 (- x ?a))
-	(+ 10 (- x ?A)))
-    (- x ?0)))
-
 (defun auto-save-unescape-name (str)
   "Undo any escaping of evil nasty characters in a file name.
 See `auto-save-escape-name'."
   (setq str (or str ""))
   (let ((tmp "")
 	(case-fold-search t))
-    (while (string-match "=[0-9a-f][0-9a-f]" str)
+    (while (string-match #r"=\([0-9a-f][0-9a-f]\)" str)
       (let* ((start (match-beginning 0))
-	     (ch1 (auto-save-unhex (elt str (+ start 1))))
-	     (code (+ (* 16 ch1)
-		      (auto-save-unhex (elt str (+ start 2))))))
+             (code (string-to-number (match-string 1 str) 16)))
 	(setq tmp (concat tmp (substring str 0 start)
 			  (char-to-string code))
 	      str (substring str (match-end 0)))))
  for history command, and as the value to return if the user enters the
  empty string."
   (let ((result
-	 (completing-read
-	  prompt
-	  (let (list)
-	    (maphash #'(lambda (key value)
-			 (push (cons (symbol-name key) value) list))
-		     behavior-hash-table)
-	    list)
-	  nil must-match initial-contents (or history 'behavior-history)
-	  default-value)))
-    (if (and result (stringp result))
+	 (completing-read prompt behavior-hash-table nil must-match
+                          initial-contents (or history 'behavior-history)
+                          default-value)))
+    (if (stringp result)
 	(intern result)
       result)))
 
       (message "Disabling behavior %s...done" behavior)
       (let ((within-behavior-enabling-disabling t))
 	(customize-set-variable 'enabled-behavior-list
-				(delq behavior enabled-behavior-list))))))
+				(delete* behavior enabled-behavior-list))))))
 
 (defun compute-behavior-group-children (group hash)
   "Compute the actual children for GROUP and its subgroups.
     )
   )
 
-(defun behavior-menu-filter-1 (menu group)
-  (submenu-generate-accelerator-spec
-   (let* (
-	  ;;options
-	  ;;help
-	  (enable
-	   (menu-split-long-menu
-	    (menu-sort-menu
-	     (let ((group-plist (gethash group behavior-group-hash-table)))
-	       (loop for behavior in (getf group-plist :children)
-		 nconc (if (behavior-group-p behavior)
-			   (list
-			    (cons (getf
-				   (gethash behavior behavior-group-hash-table)
-				   :short-doc)
-				  (behavior-menu-filter-1 menu behavior)))
-			 (let* ((plist (gethash behavior behavior-hash-table))
-				(commands (getf plist :commands)))
-			   (nconc
-			    (if (getf plist :enable)
-				`([,(format "%s (%s) [toggle]"
-					    (getf plist :short-doc)
-					    behavior)
-				   (if (memq ',behavior
-					     enabled-behavior-list)
-				       (disable-behavior ',behavior)
-				     (enable-behavior ',behavior))
-				   :active ,(if (getf plist :disable) t
-					      (not (memq
-						    ',behavior
-						    enabled-behavior-list)))
-				   :style toggle
-				   :selected (memq ',behavior
-						   enabled-behavior-list)]))
-			    (cond ((null commands) nil)
-				  ((and (eq (length commands) 1)
-					(vectorp (elt commands 0)))
-				   (let ((comm (copy-sequence
-						(elt commands 0))))
-				     (setf (elt comm 0)
-					   (format "%s (%s)"
-						   (elt comm 0) behavior))
-				     (list comm)))
-				  (t (list
-				      (cons (format "%s (%s) Commands"
-						    (getf plist :short-doc)
-						    behavior)
-					    commands)))))))))
-	     ))
-	   )
-	  )
-     enable)
-   '(?p)))
-
 (defun behavior-menu-filter (menu)
-  (append
-   `(("%_Package Utilities"
-       ("%_Set Download Site"
-	("%_Official Releases"
-	 :filter ,#'(lambda (&rest junk)
-                      (menu-split-long-menu
-                       (submenu-generate-accelerator-spec
-                        (package-ui-download-menu)))))
-	("%_Pre-Releases"
-	 :filter ,#'(lambda (&rest junk)
-                      (menu-split-long-menu
-                       (submenu-generate-accelerator-spec
-                        (package-ui-pre-release-download-menu)))))
-	("%_Site Releases"
-	 :filter ,#'(lambda (&rest junk)
-                      (menu-split-long-menu
-                       (submenu-generate-accelerator-spec
-                        (package-ui-site-release-download-menu))))))
-       "--:shadowEtchedIn"
-      ["%_Update Package Index" package-get-update-base]
-      ["%_List and Install" pui-list-packages]
-      ["U%_pdate Installed Packages" package-get-update-all]
-      ["%_Help" (Info-goto-node "(xemacs)Packages")])
-     "----")
-   (behavior-menu-filter-1 menu nil)))
+  (labels
+      ((behavior-menu-filter-1 (menu group)
+	 (submenu-generate-accelerator-spec
+	  (let* ((enable
+		  (menu-split-long-menu
+		   (menu-sort-menu
+		    (let ((group-plist (gethash group
+						behavior-group-hash-table)))
+		      (loop for behavior in (getf group-plist :children)
+			nconc (if (behavior-group-p behavior)
+				  (list
+				   (cons (getf
+					  (gethash behavior
+						   behavior-group-hash-table)
+					  :short-doc)
+					 (behavior-menu-filter-1
+					  menu behavior)))
+				(let* ((plist (gethash behavior
+						       behavior-hash-table))
+				       (commands (getf plist :commands)))
+				  (nconc
+				   (if (getf plist :enable)
+				       `([,(format "%s (%s) [toggle]"
+						   (getf plist :short-doc)
+						   behavior)
+					  (if (memq ',behavior
+						    enabled-behavior-list)
+					      (disable-behavior ',behavior)
+					    (enable-behavior ',behavior))
+					  :active ,(if (getf plist :disable)
+						       t
+						     (not
+						      (memq
+						       ',behavior
+						       enabled-behavior-list)))
+					  :style toggle
+					  :selected (memq
+						     ',behavior
+						     enabled-behavior-list)]))
+				   (cond ((null commands) nil)
+					 ((and (eq (length commands) 1)
+					       (vectorp (elt commands 0)))
+					  (let ((comm (copy-sequence
+						       (elt commands 0))))
+					    (setf (elt comm 0)
+						  (format "%s (%s)"
+							  (elt comm 0)
+							  behavior))
+					    (list comm)))
+					 (t (list
+					     (cons (format "%s (%s) Commands"
+							   (getf plist
+								 :short-doc)
+							   behavior)
+						   commands)))))))))
+		    ))
+		  )
+		 )
+	    enable)
+	  '(?p))))
+    (append
+     `(("%_Package Utilities"
+	("%_Set Download Site"
+	 ("%_Official Releases"
+	  :filter ,#'(lambda (&rest junk)
+		       (menu-split-long-menu
+			(submenu-generate-accelerator-spec
+			 (package-ui-download-menu)))))
+	 ("%_Pre-Releases"
+	  :filter ,#'(lambda (&rest junk)
+		       (menu-split-long-menu
+			(submenu-generate-accelerator-spec
+			 (package-ui-pre-release-download-menu)))))
+	 ("%_Site Releases"
+	  :filter ,#'(lambda (&rest junk)
+		       (menu-split-long-menu
+			(submenu-generate-accelerator-spec
+			 (package-ui-site-release-download-menu))))))
+	"--:shadowEtchedIn"
+	["%_Update Package Index" package-get-update-base]
+	["%_List and Install" pui-list-packages]
+	["U%_pdate Installed Packages" package-get-update-all]
+	["%_Help" (Info-goto-node "(xemacs)Packages")])
+       "----")
+     (behavior-menu-filter-1 menu nil))))
 
 ;; Initialize top-level group.
 (puthash nil '(:children nil :short-doc "Root") behavior-group-hash-table)
 
 (provide 'behavior)
 
-;;; finder-inf.el ends here
+;;; behavior.el ends here

lisp/buff-menu.el

 		 (not in-deletion)
 		 (not (eq first-buf (window-buffer (selected-window frame)))))
 	(setq buffers (cons (window-buffer (selected-window frame))
-			    (delq first-buf buffers))))
+			    (delete* first-buf buffers))))
       ;; if we're in deletion ignore the current buffer
       (when in-deletion 
-	(setq buffers (delq (current-buffer) buffers))
+	(setq buffers (delete* (current-buffer) buffers))
 	(setq first-buf (car buffers)))
       ;; filter buffers
       (when buffers-tab-filter-functions

lisp/byte-optimize.el

 	  (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name))
       (if (symbolp fn)
 	  (byte-compile-inline-expand (cons fn (cdr form)))
-	(if (compiled-function-p fn)
-	    (progn
-	      (fetch-bytecode fn)
-	      (cons (list 'lambda (compiled-function-arglist fn)
-			  (list 'byte-code
-				(compiled-function-instructions fn)
-				(compiled-function-constants fn)
-				(compiled-function-stack-depth fn)))
-		    (cdr form)))
-	  (if (eq (car-safe fn) 'lambda)
-	      (cons fn (cdr form))
-	    ;; Give up on inlining.
-	    form))))))
+	(if (or (eq (car-safe fn) 'lambda) (compiled-function-p fn))
+	    (byte-compile-unfold-lambda (cons fn (cdr form)))
+	  ;; Give up on inlining.
+	  form)))))
 
 ;;; ((lambda ...) ...)
 ;;;
   (let ((lambda (car form))
 	(values (cdr form)))
     (if (compiled-function-p lambda)
-	(setq lambda (list 'lambda (compiled-function-arglist lambda)
-			  (list 'byte-code
-				(compiled-function-instructions lambda)
-				(compiled-function-constants lambda)
-				(compiled-function-stack-depth lambda)))))
+	(setq lambda (fetch-bytecode lambda)
+              lambda (list 'lambda (compiled-function-arglist lambda)
+                           (list 'byte-code
+                                 (compiled-function-instructions lambda)
+                                 (compiled-function-constants lambda)
+                                 (compiled-function-stack-depth lambda)))))
     (let ((arglist (nth 1 lambda))
 	  (body (cdr (cdr lambda)))
 	  optionalp restp
 		(byte-compile-warn
 		 "attempt to open-code %s with too many arguments" name))
 	    form)
-	(setq body (mapcar 'byte-optimize-form body))
+	(setq body (byte-optimize-body body nil))
 	(let ((newform
 	       (if bindings
 		   (cons 'let (cons (nreverse bindings) body))
 	  newform)))))
 
 
+(defun byte-optimize-lambda (form)
+  (let* ((offset 2) (body (nthcdr offset form)))
+    (if (stringp (car body)) (setq body (nthcdr (incf offset) form)))
+    (if (eq 'interactive (car-safe (car body)))
+	(setq body (nthcdr (incf offset) form)))
+    (if (eq body (setq body (byte-optimize-body body nil)))
+        form
+      (nconc (subseq form 0 offset) body))))
+
+;; Setting this to the byte-optimizer property of condition-case gives an
+;; infinite loop, as of So 6 Mai 2012 05:10:44 IST
+(defun byte-optimize-condition-case (form &optional for-effect)
+  (let ((modified nil)
+        (result nil)
+        (new nil))
+    (setq result
+          (list* (car form) (nth 1 form)
+                 (prog1
+                     (setq new (byte-optimize-form (nth 2 form) for-effect))
+                   (setq modified (or modified (eq new (nth 2 form)))))
+                 (mapcar #'(lambda (handler)
+                             (if (eq (cdr handler)
+                                     (setq new
+                                           (byte-optimize-body (cdr handler)
+                                                               for-effect)))
+                                 handler
+                               (setq modified t)
+                               (cons (car handler) new)))
+                         (cdddr form))))
+    (if modified result form)))
+
 ;;; implementing source-level optimizers
 
 (defun byte-optimize-form-code-walker (form for-effect)
 	   (and (nth 1 form)
 		(not for-effect)
 		form))
-	  ((or (compiled-function-p fn)
-	       (eq 'lambda (car-safe fn)))
-	   (byte-compile-unfold-lambda form))
+	  ((eq fn 'function) 
+	   (when (cddr form)
+             (byte-compile-warn "malformed function form: %S" form))
+	   (cond
+            (for-effect nil)
+            ((and (eq (car-safe (cadr form)) 'lambda)
+                  (not (eq (cadr form) (setq tmp (byte-optimize-lambda
+                                                  (cadr form))))))
+             (list fn tmp))
+            (t form)))
+	  ((and (eq 'lambda (car-safe fn))
+                (not (eq form (setq form (byte-compile-unfold-lambda form)))))
+           form)
 	  ((memq fn '(let let*))
 	   ;; recursively enter the optimizer for the bindings and body
 	   ;; of a let or let*.  This for depth-firstness: forms that
 	     (byte-optimize-form (nth 1 form) for-effect)))
 	  ((eq fn 'prog1)
 	   (if (cdr (cdr form))
-	       (cons 'prog1
+	       (cons (if for-effect 'progn 'prog1)
 		     (cons (byte-optimize-form (nth 1 form) for-effect)
 			   (byte-optimize-body (cdr (cdr form)) t)))
 	     (byte-optimize-form `(or ,(nth 1 form) nil) for-effect)))
 			      (prin1-to-string form))
 	   nil)
 
-	  ((memq fn '(defun defmacro function
-		      condition-case save-window-excursion))
-	   ;; These forms are compiled as constants or by breaking out
-	   ;; all the subexpressions and compiling them separately.
-	   form)
+          ((memq fn '(defun defmacro))
+           (if (eq (setq tmp (cons 'lambda (cddr form)))
+                   (setq tmp (byte-optimize-lambda tmp)))
+               form
+             (nconc (subseq form 0 2) (cdr tmp))))
+
+          ((eq fn 'condition-case)
+           (if (eq (setq tmp (byte-optimize-condition-case form for-effect))
+                   form)
+               form
+             tmp))
 
 	  ((eq fn 'unwind-protect)
-	   ;; the "protected" part of an unwind-protect is compiled (and thus
-	   ;; optimized) as a top-level form, so don't do it here.  But the
+	   ;; the "protected" part of an unwind-protect is compiled (and
+	   ;; thus optimized) as a top-level form, but do it here too for
+	   ;; the sake of lexically-oriented code (labels, and so on).  The
 	   ;; non-protected part has the same for-effect status as the
-	   ;; unwind-protect itself.  (The protected part is always for effect,
-	   ;; but that isn't handled properly yet.)
+	   ;; unwind-protect itself.
 	   (cons fn
 		 (cons (byte-optimize-form (nth 1 form) for-effect)
-		       (cdr (cdr form)))))
+                       (byte-optimize-body (cddr form) t))))
 
 	  ((eq fn 'catch)
-	   ;; the body of a catch is compiled (and thus optimized) as a
-	   ;; top-level form, so don't do it here.  The tag is never
-	   ;; for-effect.  The body should have the same for-effect status
-	   ;; as the catch form itself, but that isn't handled properly yet.
+	   ;; The body of a catch is compiled (and thus optimized) as a
+	   ;; top-level form, but do it here too for the sake of
+	   ;; lexically-oriented code.  The tag is never for-effect.
 	   (cons fn
 		 (cons (byte-optimize-form (nth 1 form) nil)
-		       (cdr (cdr form)))))
+                       (byte-optimize-body (cddr form) for-effect))))
 
 	  ;; If optimization is on, this is the only place that macros are
 	  ;; expanded.  If optimization is off, then macroexpansion happens
 					    byte-compile-macro-environment))))
 	   (byte-optimize-form form for-effect))
 
+	  ((compiled-function-p fn)
+           (cons fn (mapcar #'byte-optimize-form (cdr form))))
+
 	  ((not (symbolp fn))
-	   (byte-compile-warn "%s is a malformed function" (prin1-to-string fn))
+           (byte-compile-warn "%S is a malformed function" fn)
 	   form)
 
 	  ;; Support compiler macros as in cl.el.
 		(setq tmp (byte-optimize-side-effect-free-p form))
 		(or byte-compile-delete-errors
 		    (eq tmp 'error-free)
+                    ;; XEmacs; GNU handles the expansion of (pop foo) specially
+                    ;; here. We changed the macro to expand to (prog1 (car-safe
+                    ;; PLACE) (setq PLACE (cdr PLACE))) , which has the same
+                    ;; effect. (This only matters when
+                    ;; byte-compile-delete-errors is nil, which is usually true
+                    ;; for GNU and usually false for XEmacs.)
 		    (progn
 		      (byte-compile-warn "%s called for effect"
 					 (prin1-to-string form))
   ;; all-for-effect is true.  Returns a new list of forms.
   (let ((rest forms)
 	(result nil)
+        (modified nil)
 	fe new)
     (while rest
       (setq fe (or all-for-effect (cdr rest)))
       (setq new (and (car rest) (byte-optimize-form (car rest) fe)))
       (if (or new (not fe))
-	  (setq result (cons new result)))
+	  (setq result (cons new result)
+                modified (or modified (not (eq new (car rest)))))
+        (setq modified t))
       (setq rest (cdr rest)))
-    (nreverse result)))
+    (if modified (nreverse result) forms)))
 
 
 ;;; some source-level optimizers
 			    (apply fun (mapcar 'float constants))
 			    (float (apply fun constants)))))
 		(setq form orig)
-	      (setq form (nconc (delq nil form)
+	      (setq form (nconc (delete* nil form)
 				(list (apply fun (nreverse constants)))))))))
     form))
 
    (cond ((memq 0 form)
 	  (setq form (if (eq (car form) 'logand)
 			 (cons 'progn (cdr form))
-		       (delq 0 (copy-sequence form)))))
+		       (remove* 0 form))))
 	 ((and (eq (car-safe form) 'logior)
 	       (memq -1 form))
 	  (cons 'progn (cdr form)))
 	 (nth 1 form))
 	((byte-optimize-predicate form))))
 
-(defun byte-optimize-or (form)
+(defun byte-optimize-or (form &optional for-effect)
   ;; Throw away unneeded nils, and simplify if less than 2 args.
   ;; XEmacs; change to be more careful about discarding multiple values. 
-  (let* ((memqueued (memq nil form))
-         (trailing-nil (and (cdr memqueued)
-                            (equal '(nil) (last form))))
-         rest)
-    ;; A trailing nil indicates to discard multiple values, and we need to
-    ;; respect that:
-    (when (and memqueued (cdr memqueued))
-      (setq form (delq nil (copy-sequence form)))
-      (when trailing-nil
-        (setcdr (last form) '(nil))))
-    (setq rest form)
-    ;; If there is a literal non-nil constant in the args to `or', throw
-    ;; away all following forms. We can do this because a literal non-nil
-    ;; constant cannot be multiple.
+  (if (memq nil form)
+      (setq form (remove* nil form
+                          ;; A trailing nil indicates to discard multiple
+                          ;; values, and we need to respect that. No need if
+                          ;; this is for-effect, though, multiple values
+                          ;; will be discarded anyway.
+                          :end (if (not for-effect) (1- (length form))))))
+  ;; If there is a literal non-nil constant in the args to `or', throw
+  ;; away all following forms. We can do this because a literal non-nil
+  ;; constant cannot be multiple.
+  (let ((rest form))
     (while (cdr (setq rest (cdr rest)))
       (if (byte-compile-trueconstp (car rest))
 	  (setq form (copy-sequence form)
 
 (put 'and   'byte-optimizer 'byte-optimize-and)
 (put 'or    'byte-optimizer 'byte-optimize-or)
+(put 'or    'byte-for-effect-optimizer
+     #'(lambda (form) (byte-optimize-or form t)))
 (put 'cond  'byte-optimizer 'byte-optimize-cond)
 (put 'if    'byte-optimizer 'byte-optimize-if)
 (put 'while 'byte-optimizer 'byte-optimize-while)
 	 ;; No bindings
 	 (cons 'progn (cdr (cdr form))))
 	((or (nth 2 form) (nthcdr 3 form))
-	 form)
+	 (if (and (eq 'let (car form)) (> (length (nth 1 form)) 2))
+	     ;; Group constant initialisations together, so we can
+	     ;; just dup in the lap code. Can't group other
+	     ;; initialisations together if they have side-effects,
+	     ;; that would re-order them.
+	     (let ((sort (stable-sort
+			  (copy-list (nth 1 form))
+			  #'< :key #'(lambda (object)
+				       (cond ((atom object)
+					      most-positive-fixnum)
+					     ((null (cadr object))
+					      most-positive-fixnum)
+					     ((byte-compile-trueconstp
+					       (cadr object))
+					      (mod (sxhash (cadr object))
+						   most-positive-fixnum))
+					     (t 0))))))
+	       (if (equal sort (nth 1 form))
+		   form
+		 `(let ,sort ,@(cddr form))))
+	   form))
 	 ;; The body is nil
 	((eq (car form) 'let)
 	 (append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form)))
 	       ;; this addr is jumped to
 	       (setcdr rest (cons (cons nil (cdr tmp))
 				  (cdr rest)))
-	       (setq tags (delq tmp tags))
+	       (setq tags (delete* tmp tags))
 	       (setq rest (cdr rest))))
 	(setq rest (cdr rest))))
     (if tags (error "optimizer error: missed tags %s" tags))
 	       (cond ((= tmp 1)
 		      (byte-compile-log-lap
  		       "  %s discard\t-->\t<deleted>" lap0)
-		      (setq lap (delq lap0 (delq lap1 lap))))
+		      (setq lap (delete* lap0 (delete* lap1 lap))))
 		     ((= tmp 0)
 		      (byte-compile-log-lap
 		       "  %s discard\t-->\t<deleted> discard" lap0)
-		      (setq lap (delq lap0 lap)))
+		      (setq lap (delete* lap0 lap)))
 		     ((= tmp -1)
 		      (byte-compile-log-lap
 		       "  %s discard\t-->\tdiscard discard" lap0)
 	      ((and (memq (car lap0) byte-goto-ops)
 		    (eq (cdr lap0) lap1))
 	       (cond ((eq (car lap0) 'byte-goto)
-		      (setq lap (delq lap0 lap))
+		      (setq lap (delete* lap0 lap))
 		      (setq tmp "<deleted>"))
 		     ((memq (car lap0) byte-goto-always-pop-ops)
 		      (setcar lap0 (setq tmp 'byte-discard))
 	       (byte-compile-log-lap "  dup %s discard\t-->\t%s" lap1 lap1)
 	       (setq keep-going t
 		     rest (cdr rest))
-	       (setq lap (delq lap0 (delq lap2 lap))))
+	       (setq lap (delete* lap0 (delete* lap2 lap))))
 	      ;;
 	      ;; not goto-X-if-nil              -->  goto-X-if-non-nil
 	      ;; not goto-X-if-non-nil          -->  goto-X-if-nil
 	       (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
 				'byte-goto-if-not-nil
 				'byte-goto-if-nil))
-	       (setq lap (delq lap0 lap))
+	       (setq lap (delete* lap0 lap))
 	       (setq keep-going t))
 	      ;;
 	      ;; goto-X-if-nil     goto-Y X:  -->  goto-Y-if-non-nil X:
 		 (byte-compile-log-lap "  %s %s %s:\t-->\t%s %s:"
 				       lap0 lap1 lap2
 				       (cons inverse (cdr lap1)) lap2)
-		 (setq lap (delq lap0 lap))
+		 (setq lap (delete* lap0 lap))
 		 (setcar lap1 inverse)
 		 (setq keep-going t)))
 	      ;;
 		      (byte-compile-log-lap "  %s %s\t-->\t<deleted>"
 					    lap0 lap1)
 		      (setq rest (cdr rest)
-			    lap (delq lap0 (delq lap1 lap))))
+			    lap (delete* lap0 (delete* lap1 lap))))
 		     (t
 		      (if (memq (car lap1) byte-goto-always-pop-ops)
 			  (progn
 			    (byte-compile-log-lap "  %s %s\t-->\t%s"
 			     lap0 lap1 (cons 'byte-goto (cdr lap1)))
-			    (setq lap (delq lap0 lap)))
+			    (setq lap (delete* lap0 lap)))
 			(byte-compile-log-lap "  %s %s\t-->\t%s" lap0 lap1
 			 (cons 'byte-goto (cdr lap1))))
 		      (setcar lap1 'byte-goto)))
 	       (while (setq tmp2 (rassq lap0 tmp3))
 		 (setcdr tmp2 lap1)
 		 (setq tmp3 (cdr (memq tmp2 tmp3))))
-	       (setq lap (delq lap0 lap)
+	       (setq lap (delete* lap0 lap)
 		     keep-going t))
 	      ;;
 	      ;; unused-TAG: --> <deleted>
 		    (not (rassq lap0 lap)))
 	       (and (memq byte-optimize-log '(t byte))
 		    (byte-compile-log "  unused tag %d removed" (nth 1 lap0)))
-	       (setq lap (delq lap0 lap)
+	       (setq lap (delete* lap0 lap)
 		     keep-going t))
 	      ;;
 	      ;; goto   ... --> goto   <delete until TAG or end>
 				       byte-save-restriction))
 		    (< 0 (cdr lap1)))
 	       (if (zerop (setcdr lap1 (1- (cdr lap1))))
-		   (delq lap1 rest))
+		   (delete* lap1 rest))
 	       (if (eq (car lap0) 'byte-varbind)
 		   (setcar rest (cons 'byte-discard 0))
-		 (setq lap (delq lap0 lap)))
+		 (setq lap (delete* lap0 lap)))
 	       (byte-compile-log-lap "  %s %s\t-->\t%s %s"
 		 lap0 (cons (car lap1) (1+ (cdr lap1)))
 		 (if (eq (car lap0) 'byte-varbind)
 			  (setcdr tmp (cons (byte-compile-make-tag)
 					    (cdr tmp))))
 		      (setcdr lap1 (car (cdr tmp)))
-		      (setq lap (delq lap0 lap))))
+		      (setq lap (delete* lap0 lap))))
 	       (setq keep-going t))
 	      ;;
 	      ;; X: varref-Y    ...     varset-Y goto-X  -->
 				   (cons 'byte-unbind
 					 (+ (cdr lap0) (cdr lap1))))
 	     (setq keep-going t)
-	     (setq lap (delq lap0 lap))
+	     (setq lap (delete* lap0 lap))
 	     (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
 	    )
       (setq rest (cdr rest)))
           #'(lambda (form &optional read-only)
               (list wrapper form))))
     (labels
-        . ,#'(lambda (bindings &rest body)
-               (let* ((names (mapcar 'car bindings))
-                      (lambdas (mapcar
-                                (function*
-                                 (lambda ((name . definition))
-                                   (cons 'lambda (cdr (cl-transform-lambda
-                                                       definition name)))))
-                                bindings))
-                      (placeholders
-                       (mapcar #'(lambda (lambda)
-                                   (make-byte-code (second lambda) "\xc0\x87"
-                                                   ;; This list is used for
-                                                   ;; the byte-optimize
-                                                   ;; property, if the
-                                                   ;; function is to be
-                                                   ;; inlined. See
-                                                   ;; cl-do-proclaim.
-                                                   (vector nil) 1))
-                               lambdas))
-                      (byte-compile-macro-environment
-                       (pairlis names (mapcar
-                                       #'(lambda (placeholder)
-                                           `(lambda (&rest cl-labels-args)
-                                              ;; Be careful not to quote
-                                              ;; PLACEHOLDER, otherwise
-                                              ;; byte-optimize-funcall inlines
-                                              ;; it.
-                                              (list* 'funcall ,placeholder
-                                                     cl-labels-args)))
-                                       placeholders)
-                                byte-compile-macro-environment))
-                      (gensym (gensym)))
-                 (labels
-                     ((byte-compile-transform-labels (form names lambdas
-                                                      placeholders)
-                        (let* ((inline
-                                 (mapcan
-                                  #'(lambda (name placeholder lambda)
-                                      (and
-                                       (eq
-                                        (getf (aref
-                                               (compiled-function-constants
-                                                placeholder) 0)
-                                              'byte-optimizer)
-                                        'byte-compile-inline-expand)
-                                       `(((function ,placeholder)
-                                          ,(byte-compile-lambda lambda name)
-                                          (function ,lambda)))))
-                                  names placeholders lambdas))
-                               (compiled
-                                (mapcar* #'byte-compile-lambda 
-                                         (if (not inline)
-                                             lambdas
-                                           ;; See further down for the
-                                          ;; rationale of the sublis calls.
-                                           (sublis (pairlis
-                                                    (mapcar #'cadar inline)
-                                                    (mapcar #'third inline))
-                                                   (sublis
-                                                    (pairlis
-                                                     (mapcar #'car inline)
-                                                     (mapcar #'second inline))
-                                                    lambdas :test #'equal)
-                                                   :test #'eq))
-                                         names))
-                               elt)
-                          (mapc #'(lambda (placeholder function)
-                                    (nsubst function placeholder compiled
-                                            :test #'eq
-                                            :descend-structures t))
-                                placeholders compiled)
-                          (when inline
-                            (dolist (triad inline)
-                              (nsubst (setq elt (elt compiled
-                                                     (position (cadar triad)
-                                                               placeholders)))
-                                      (second triad) compiled :test #'eq
-                                      :descend-structures t)
-                              (setf (second triad) elt))
-                            ;; For inlined labels: first, replace uses of
-                            ;; the placeholder in places where it's not an
-                            ;; evident, explicit funcall (that is, where
-                            ;; it is not to be inlined) with the compiled
-                            ;; function:
-                            (setq form (sublis
-                                        (pairlis (mapcar #'car inline)
-                                                 (mapcar #'second inline))
-                                        form :test #'equal)
-                                  ;; Now replace uses of the placeholder
-                                  ;; where it is an evident funcall with the
-                                  ;; lambda, quoted as a function, to allow
-                                  ;; byte-optimize-funcall to do its
-                                  ;; thing. Note that the lambdas still have
-                                  ;; the placeholders, so there's no risk
-                                  ;; of recursive inlining.
-                                  form (sublis (pairlis
-                                                (mapcar #'cadar inline)
-                                                (mapcar #'third inline))
-                                               form :test #'eq)))
-                          (sublis (pairlis placeholders compiled) form
-                                  :test #'eq))))
-                   (put gensym 'byte-compile
-                        #'(lambda (form)
-                            (let* ((names (cadr (cl-pop2 form)))
-                                   (lambdas (mapcar #'cadr (cdr (pop form))))
-                                   (placeholders (cadr (pop form))))
-                              (byte-compile-body-do-effect
-                               (byte-compile-transform-labels form names
-                                                              lambdas
-                                                              placeholders)))))
-                   (put gensym 'byte-hunk-handler
-                        #'(lambda (form)
-                            (let* ((names (cadr (cl-pop2 form)))
-                                   (lambdas (mapcar #'cadr (cdr (pop form))))
-                                   (placeholders (cadr (pop form))))
-                              (byte-compile-file-form
-                               (cons 'progn
-                                     (byte-compile-transform-labels
-                                      form names lambdas placeholders))))))
-		   (setq body
-			 (cl-macroexpand-all `(,gensym ',names (list ,@lambdas)
-					       ',placeholders ,@body)
-					     byte-compile-macro-environment))
-		   (if (position 'lambda (mapcar #'(lambda (object)
-						     (car-safe (cdr-safe
-								object)))
-						 (cdr (third body)))
-				 :key #'car-safe :test-not #'eq)
-		       ;; #'lexical-let has worked its magic, not all the
-		       ;; lambdas are lambdas. Give up on pre-compiling the
-		       ;; labels.
-		       (setq names (mapcar #'copy-symbol names)
-			     lambdas (cdr (third body))
-			     body (sublis (pairlis placeholders names)
-					  (nthcdr 4 body) :test #'eq)
-			     lambdas (sublis (pairlis placeholders names)
-					     lambdas :test #'eq)
-			     body (cl-macroexpand-all
-				   `(lexical-let
-				     ,names
-				     (setf ,@(mapcan #'list names lambdas))
-				     ,@body)
-				   byte-compile-macro-environment))
-		     body)))))
+        . ,(symbol-macrolet ((wrapper '#:labels))
+             (labels
+                 ((cannot-inline-alist (placeholders lambdas)
+		    (let ((inline
+			    ;; What labels should be inline?
+			    (remove-if-not
+			     #'(lambda (placeholder)
+				 (eq 'byte-compile-inline-expand
+				     (get placeholder
+					  'byte-optimizer)))
+			     placeholders)))
+		      ;; Which of those labels--that should be
+		      ;; inline--reference themeselves, or other labels that
+		      ;; should be inline? Give a an alist mapping them to
+		      ;; their data placeholders.
+		      (mapcan
+		       #'(lambda (placeholder lambda)
+			   (and
+			    (eq 'byte-compile-inline-expand
+				(get placeholder 'byte-optimizer))
+			    (block find
+			      (subst-if nil
+					#'(lambda (tree)
+					    (if (memq tree inline)
+						(return-from find t)))
+					lambda)
+			      nil)
+			    `((,placeholder
+			       . ,(get placeholder
+                                       'byte-compile-data-placeholder)))))
+		       placeholders lambdas)))
+                  (destructure-labels (form for-effect)
+                    (let* ((names (cadr (cl-pop2 form)))
+                           (lambdas (mapcar #'cadr (cdr (pop form))))
+                           (placeholders (cadr (pop form)))
+                           (cannot-inline-alist (cannot-inline-alist
+                                                 placeholders lambdas))
+                           (lambdas (sublis cannot-inline-alist
+                                            lambdas :test #'eq)))
+                      ;; Used specially, note the bindings in our callers.
+                      (setq byte-compile-function-environment
+                            (pairlis
+                             (mapcar #'cdr cannot-inline-alist)
+                             (mapcar #'car cannot-inline-alist)
+                             (pairlis placeholders lambdas
+                                      byte-compile-function-environment)))
+                      (if (memq byte-optimize '(t source))
+                          (setq lambdas
+                                (mapcar #'cadr (mapcar #'byte-optimize-form
+                                                       lambdas))
+                                form (byte-optimize-body form for-effect)))
+                      (values placeholders lambdas names form)))
+                  (warn-about-unused-labels (names placeholders)
+                    (when (memq 'unused-vars byte-compile-warnings)
+                      (loop
+                        for placeholder in placeholders
+                        for name in names
+                        if (eql 0 (+ (get placeholder
+                                          'byte-compile-label-calls 0)
+                                     (get (get placeholder
+                                               'byte-compile-data-placeholder
+                                               '#:no-such-data-placeholder)
+                                          'byte-compile-label-calls 0)))
+                        do (byte-compile-warn
+                            "label %s bound but not referenced" name))))
+                  (byte-compile-transform-labels (form names lambdas
+                                                  placeholders)
+                    (let ((compiled
+                           (mapcar* #'byte-compile-lambda lambdas names)))
+                      (warn-about-unused-labels names placeholders)
+                      (mapc #'(lambda (placeholder function)
+                                (nsubst function placeholder compiled
+                                        :test #'eq
+                                        :descend-structures t)
+                                (nsubst function
+                                        (get placeholder
+                                             'byte-compile-data-placeholder)
+                                        compiled :test #'eq
+                                        :descend-structures t))
+                            placeholders compiled)
+                      (sublis (pairlis
+                               placeholders compiled
+                               (pairlis
+                                (mapcar*
+                                 #'get placeholders
+                                 (load-time-value
+                                  (let ((list
+                                         (list
+                                          'byte-compile-data-placeholder)))
+                                    (nconc list list))))
+                                compiled))
+                              form :test #'eq))))
+               (put wrapper 'byte-compile
+                    #'(lambda (form)
+                        (let ((byte-compile-function-environment
+                               byte-compile-function-environment))
+                          (multiple-value-bind
+                              (placeholders lambdas names form)
+                              (destructure-labels form for-effect)
+                            (byte-compile-body-do-effect
+                             (byte-compile-transform-labels form names
+                                                            lambdas
+                                                            placeholders))))))
+               (put wrapper 'byte-hunk-handler
+                    #'(lambda (form)
+                        (let ((byte-compile-function-environment
+                               byte-compile-function-environment))
+                          (multiple-value-bind
+                              (placeholders lambdas names form)
+                              (destructure-labels form t)
+                            (byte-compile-file-form
+                             (cons 'progn
+                                   (byte-compile-transform-labels
+                                    form names lambdas placeholders)))))))
+	       (put wrapper 'cl-compiler-macro
+		    ;; This is only used when optimizing code.
+		    #'(lambda (form &rest ignore)
+                        (let ((byte-compile-function-environment
+                               byte-compile-function-environment)
+                              byte-optimize-form retry)
+                          (multiple-value-bind
+                              (placeholders lambdas)
+                              (destructure-labels form for-effect)
+                            ;; Optimize most of the form, in passing
+                            ;; expanding macros.
+                            (setq byte-optimize-form
+                                  (mapcar #'byte-optimize-form
+                                          (list* (nth 1 form) `(list ,@lambdas)
+                                                 (cdddr form))))
+                            ;; It may be reasonable to inline any labels
+                            ;; used only once.
+                            (dolist (placeholder placeholders)
+                              (and 
+                               (not (eq 'byte-compile-inline-expand
+                                        (get placeholder 'byte-optimizer)))
+                               (eql 0 (get (get placeholder
+                                                'byte-compile-data-placeholder
+                                                '#:no-such-data-placeholder)
+                                           'byte-compile-label-calls 0))
+                               (eql 1 (get placeholder
+                                           'byte-compile-label-calls 0))
+                               (progn
+				 (byte-compile-log
+				  "label %s is used only once, inlining it"
+				  placeholder)
+				 (setq retry t)
+				 (cl-do-proclaim `(inline ,placeholder) t))))
+                            (when retry
+                              (multiple-value-setq
+                                  (placeholders lambdas)
+                                (destructure-labels form for-effect))
+                              (setq byte-optimize-form
+                                    (mapcar #'byte-optimize-form
+                                            (list* (nth 1 form)
+                                                   `(list ,@lambdas)
+                                                   (cdddr form)))))
+                            (if (equal (cdr form) byte-optimize-form)
+                                form
+                              (cons (car form) byte-optimize-form)))))))
+             #'(lambda (bindings &rest body)
+                 (let* ((names (mapcar 'car bindings))
+                        (lambdas (mapcar
+                                  (function*
+                                   (lambda ((name . definition))
+                                     `#'(lambda ,@(cdr (cl-transform-lambda
+                                                        definition name)))))
+                                  bindings))
+                        (placeholders (mapcar #'copy-symbol names))
+                        (byte-compile-macro-environment
+                         (pairlis names
+                                  (mapcar
+                                   #'(lambda (placeholder)
+                                       `(lambda (&rest byte-compile-labels-args)
+                                          (put
+                                           ',placeholder
+                                           'byte-compile-label-calls
+                                           (1+ (get ',placeholder
+                                                    'byte-compile-label-calls
+                                                    0)))
+                                          (cons ',placeholder
+                                                byte-compile-labels-args)))
+                                   placeholders)
+                                  byte-compile-macro-environment)))
+                   ;; Tell the macroexpansion code what symbol to use when
+                   ;; expanding #'FUNCTION-NAME:
+                   (mapc #'put placeholders
+                         (load-time-value
+                          (let ((list (list 'byte-compile-data-placeholder)))
+                            (nconc list list)))
+                         (mapcar #'copy-symbol names))
+                   (setq body
+                         (cl-macroexpand-all
+                          `(,wrapper ',names (list ,@lambdas) ',placeholders
+                                      ,@body)
+                          byte-compile-macro-environment))
+                   (if (position 'lambda (mapcar #'(lambda (object)
+                                                     (car-safe (cdr-safe
+                                                                object)))
+                                                 (cdr (third body)))
+                                 :key #'car-safe :test-not #'eq)
+                       ;; #'lexical-let has worked its magic, not all the
+                       ;; lambdas are lambdas. Give up on pre-compiling the
+                       ;; labels.
+                       (setq names (mapcar #'copy-symbol names)
+                             lambdas (cdr (third body))
+                             body (sublis (pairlis placeholders names)
+                                          (nthcdr 4 body) :test #'eq)
+                             lambdas (sublis (pairlis placeholders names)
+                                             lambdas :test #'eq)
+                             body (cl-macroexpand-all
+                                   `(lexical-let
+                                     ,names
+                                     (setf ,@(mapcan #'list names lambdas))
+                                     ,@body)
+                                   byte-compile-macro-environment))
+                     body)))))
     (flet .
       ,#'(lambda (bindings &rest body)
            (let* ((names (mapcar 'car bindings))
 		    (byte-compile-arglist-signature-string (cons min max))))
 
 	      (setq byte-compile-unresolved-functions
-		    (delq calls byte-compile-unresolved-functions)))))
+		    (delete* calls byte-compile-unresolved-functions)))))
       )))
 
 ;; If we have compiled any calls to functions which are not known to be
 	   (while rest
 	     (if (assq (car (car rest)) byte-compile-autoload-environment)
 		 (setq byte-compile-unresolved-functions
-		       (delq (car rest) byte-compile-unresolved-functions)))
+		       (delete* (car rest) byte-compile-unresolved-functions)))
 	     (setq rest (cdr rest)))))
      ;; Now warn.
      (if (cdr byte-compile-unresolved-functions)
 
        (unwind-protect
 	   (call-with-condition-handler
-	       #'(lambda (error-info)
-		   (byte-compile-report-error error-info))
+               #'byte-compile-report-error
 	       #'(lambda ()
 		   (progn ,@body)))
 	 ;; Always set point in log to start of interesting output.
   (eval form)
   (byte-compile-keep-pending form 'byte-compile-normal-call))
 
-;; XEmacs change: be careful about multiple values with these three forms.
-(put 'progn 'byte-hunk-handler
-     #'(lambda (form)
-         (mapc 'byte-compile-file-form (cdr form))
-         ;; Return nil so the forms are not output twice.
-         nil))
-
-(put 'prog1 'byte-hunk-handler
-     #'(lambda (form)
-         (when (first form)
-           (byte-compile-file-form `(or ,(first form) nil))
-           (mapc 'byte-compile-file-form (cdr form))
-           nil)))
-
-(put 'prog2 'byte-hunk-handler
-     #'(lambda (form)
-         (when (first form)
-           (byte-compile-file-form (first form))
-           (when (second form)
-             (setq form (cdr form))
-             (byte-compile-file-form `(or ,(first form) nil))
-             (mapc 'byte-compile-file-form (cdr form))
-             nil))))
+(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
+(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
+(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn)
+(defun byte-compile-file-form-progn (form)
+  (mapc 'byte-compile-file-form (cdr form))
+  ;; Return nil so the forms are not output twice.
+  nil)
 
 ;; This handler is not necessary, but it makes the output from dont-compile
 ;; and similar macros cleaner.
 	  (let ((new-bindings
 		 (mapcar #'(lambda (x) (cons x byte-compile-arglist-bit))
 			 (and (memq 'free-vars byte-compile-warnings)
-			      (delq '&rest (delq '&optional
-						 (copy-sequence arglist)))))))
+			      (remove* '&rest (remove* '&optional arglist))))))
 	    (nconc new-bindings
 		   (cons 'new-scope byte-compile-bound-variables))))
 	 (body (cdr (cdr fun)))
 				     (cons (nth 1 (car body)) (cdr body))
 				   (cons tmp body))))
 		     (or (eq output-type 'file)
-			 (not (delq nil (mapcar 'consp (cdr (car body))))))))
+                         (notany #'consp (cdar body)))))
 	      (setq rest (cdr rest)))
 	    rest))
       (let ((byte-compile-vector (byte-compile-constants-vector)))
 	     (if (memq 'callargs byte-compile-warnings)
 		 (byte-compile-callargs-warn form))
 	     (byte-compile-normal-call form))))
-	((and (or (compiled-function-p (car form))
-		  (eq (car-safe (car form)) 'lambda))
+	((and (eq (car-safe (car form)) 'lambda)
 	      ;; if the form comes out the same way it went in, that's
 	      ;; because it was malformed, and we couldn't unfold it.
 	      (not (eq form (setq form (byte-compile-unfold-lambda form)))))
 (map nil
      (function*
       (lambda ((function . nargs))
-	;; Document that the car of OBJECT, a symbol, describes a function
-	;; taking keyword arguments from the argument index described by
-	;; the cdr of OBJECT.
+	;; Document that FUNCTION, a symbol, describes a function taking
+	;; keyword arguments from the argument index described by NARGS.
 	(put function 'byte-compile-keyword-start nargs)))
      '((adjoin . 3) (assoc* . 3) (assoc-if . 3) (assoc-if-not . 3)
        (count . 3) (count-if . 3) (count-if-not . 3) (define-behavior . 3)
 	 (if (cdr (cdr form))
 	     (byte-compile-out 'byte-insertN (length (cdr form)))
 	   (byte-compile-out 'byte-insert 0)))
-	((memq t (mapcar 'consp (cdr (cdr form))))
+	((some #'consp (cddr form))
 	 (byte-compile-normal-call form))
 	;; We can split it; there is no function call after inserting 1st arg.
 	(t
            (byte-compile-constp (second form)))
       (byte-compile-callargs-warn (cons (cl-const-expr-val (second form))
                                         (nthcdr 2 form))))
-  (if (and byte-optimize
-           (eq 'function (car-safe (cadr form)))
-           (eq 'lambda (car-safe (cadadr form)))
-	    (or
-	     (not (eq (setq form (cons (cadadr form) (cddr form)))
-		      (setq form (byte-compile-unfold-lambda form))))
-	     (prog1 nil (setq form `(funcall #',(car form) ,@(cdr form))))))
-      ;; The byte-compile part of the #'labels implementation, above,
-      ;; happens after macroexpansion and after the source optimizer has
-      ;; done its thing. When labels are to be made inline we can have code
-      ;; that looks like (funcall #'(lambda ...) ...), when the code that
-      ;; the optimizer saw looked like (funcall #<compiled-function ...>
-      ;; ...).
-      ;;
-      ;; So, the optimizer doesn't have the opportunity to transform the
-      ;; former to (let (...) ...), and it's reasonable to do that here (since
-      ;; the labels implementation doesn't change other code that would need
-      ;; running through the optimizer; the lambda itself has already been
-      ;; through the optimizer).
-      ;;
-      ;; Equally reasonable, and conceptually a bit clearer, would be to do
-      ;; the transformation to (funcall #'(lambda ...) ...) in the
-      ;; byte-optimizer, breaking most of the #'sublis calls out of the
-      ;; byte-compile method.
-      (byte-compile-form form)
-    (mapc 'byte-compile-form (cdr form))
-    (byte-compile-out 'byte-call (length (cdr (cdr form))))))
-
+  (mapc 'byte-compile-form (cdr form))
+  (byte-compile-out 'byte-call (length (cdr (cdr form)))))
 
 (defun byte-compile-let (form)
   ;; First compute the binding values in the old scope.
   (let ((calls (assq new byte-compile-unresolved-functions)))
     (if calls
 	(setq byte-compile-unresolved-functions
-	      (delq calls byte-compile-unresolved-functions)))))
+	      (delete* calls byte-compile-unresolved-functions)))))
 
 ;;; tags
 
   (batch-byte-recompile-directory))
 
 ;;;###autoload
-(defun batch-byte-recompile-directory ()
+(defun batch-byte-recompile-directory (&optional arg)
   "Runs `byte-recompile-directory' on the dirs remaining on the command line.
 Must be used only with `-batch', and kills Emacs on completion.
-For example, invoke `xemacs -batch -f batch-byte-recompile-directory .'."
+For example, invoke `xemacs -batch -f batch-byte-recompile-directory .'.
+
+The optional argument is passed to `byte-recompile-directory' as the
+prefix argument; see the documentation there for its meaing.
+In particular, passing 0 means to compile files for which no `.elc' files
+exist."
   ;; command-line-args-left is what is left of the command line (startup.el)
   (defvar command-line-args-left)	;Avoid 'free variable' warning
   (if (not noninteractive)
       (setq command-line-args-left '(".")))
   (let ((byte-recompile-directory-ignore-errors-p t))
     (while command-line-args-left
-      (byte-recompile-directory (car command-line-args-left))
+      (byte-recompile-directory (car command-line-args-left) arg)
       (setq command-line-args-left (cdr command-line-args-left))))
   (kill-emacs 0))
 
            ;; This is a bit of a hack; special-case symbols with bindings as
            ;; labels.
 	   (let ((found (cdr (assq (cadr form) env))))
-	     (if (and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
-                 (if (consp (nth 2 (nth 2 found)))
-                     ;; It's a cons; this is the implementation of
-                     ;; labels in cl-macs.el.
-                     (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env)
-                   ;; It's an atom, almost certainly a compiled function;
-                   ;; we're using the implementation of labels in
-                   ;; bytecomp.el. Quote it with FUNCTION so that code can
-                   ;; tell uses as data apart from the uses with funcall,
-                   ;; where it's unquoted. #### We should warn if (car form)
-                   ;; above is quote, rather than function.
-                   (list 'function (nth 2 (nth 2 found))))
-	       form))))
+	     (cond
+              ((and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
+               ;; This is the implementation of labels in cl-macs.el.
+               (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env))
+              ((and (consp found) (eq (nth 1 (nth 1 found))
+                                      'byte-compile-labels-args))
+               ;; We're using the implementation of labels in
+               ;; bytecomp.el. Quote its data-placeholder with FUNCTION so
+               ;; that code can tell uses as data apart from the uses with
+               ;; funcall.
+               (unless (eq 'function (car form))
+                 (byte-compile-warn
+                  "deprecated: '%s, use #'%s instead to quote it as a function"
+                  (cadr form) (cadr form)))
+               (setq found (get (nth 1 (nth 1 (nth 3 found)))
+                                'byte-compile-data-placeholder))
+               (put found 'byte-compile-label-calls
+                    (1+ (get found 'byte-compile-label-calls 0)))
+               (list 'function found))
+              (t form)))))
 	((memq (car form) '(defun defmacro))
 	 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
 	((and (eq (car form) 'progn) (not (cddr form)))
 ;;; Code:
 
 (defmacro cl-pop2 (place)
-  (list 'prog1 (list 'car (list 'cdr place))
+  (list 'prog1 (list 'car-safe (list 'cdr-safe place))
 	(list 'setq place (list 'cdr (list 'cdr place)))))
 (put 'cl-pop2 'edebug-form-spec 'edebug-sexps)
 
    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'.
+   &environment allows access to the macro environment at the time of
+   expansion; it is most relevant when it's necessary to force macro expansion
+   of the body of a form at the time of macro expansion of its top level.
+   &environment is followed by variable name, and this variable will be bound
+   to the value of the macro environment within 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
 	   ;; 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 (delete* '&cl-defs (delete* junk arg))))
 	   (if (memq '&cl-quote arg)
-	       (setq arg (delq '&cl-quote arg)))
+	       (setq arg (delete* '&cl-quote arg)))
 	   (mapcar 'cl-upcase-arg arg)))
 	(t arg)))                         ; Maybe we are in initializer
 
     (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)))
-	(setq args (delq '&cl-defs (delq bind-defs args))
+	(setq args (delete* '&cl-defs (delete* bind-defs args))
 	      bind-defs (cadr bind-defs)))
     (if (setq bind-enquote (memq '&cl-quote args))
-	(setq args (delq '&cl-quote args)))
+	(setq args (delete* '&cl-quote args)))
     (if (memq '&whole args) (error "&whole not currently implemented"))
     (let* ((p (memq '&environment args)) (v (cadr p)))
-      (if p (setq args (nconc (delq (car p) (delq v args))
+      (if p (setq args (nconc (delete* (car p) (delete* v args))
                               `(&aux (,v byte-compile-macro-environment))))))
     (while (and args (symbolp (car args))
 		(not (memq (car args) '(nil &rest &body &key &aux)))
     ;; as such it can eliminate it if that's appropriate:
     (put (cdar cl-active-block-names) 'cl-block-name name)
     `(catch ',(cdar cl-active-block-names)
+      ;; Can't use &environment, since #'block is used in
+      ;; #'cl-transform-lambda.
       ,(cl-macroexpand-all body byte-compile-macro-environment))))
 
 ;;;###autoload
 	      '(cl-progv-after))))
 
 ;;;###autoload
-(defmacro* macrolet ((&rest macros) &body form)
+(defmacro* macrolet ((&rest macros) &body form &environment env)
   "Make temporary macro definitions.
 This is like `flet', but for macros instead of functions."
   (cl-macroexpand-all (cons 'progn form)
                          collect
                          (list* name 'lambda (cdr (cl-transform-lambda details
                                                                        name))))
-                       byte-compile-macro-environment)))
+                       env)))
 
 ;;;###autoload
-(defmacro* symbol-macrolet ((&rest symbol-macros) &body form)
+(defmacro* symbol-macrolet ((&rest symbol-macros) &body form &environment env)
   "Make temporary symbol macro definitions.
 Elements in SYMBOL-MACROS look like (NAME EXPANSION).
 Within the body FORMs, a reference to NAME is replaced with its EXPANSION,
 			       for (name expansion) in symbol-macros
 			       do (check-type name symbol)
 			       collect (list (eq-hash name) expansion))
-			     byte-compile-macro-environment)))
+			     env)))
 
 (defvar cl-closure-vars nil)
 ;;;###autoload
-(defmacro lexical-let (bindings &rest body)
+(defmacro* lexical-let (bindings &rest body &environment env)
   "Like `let', but lexically scoped.
 The main visible difference is that lambdas inside BODY will create
 lexical closures as in Common Lisp."
 				    t))
 			  vars)
 		  (list '(defun . cl-defun-expander))
-		  byte-compile-macro-environment))))
+		  env))))
     (if (not (get (car (last cl-closure-vars)) 'used))
 	(list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars)
 	      (sublis (mapcar #'(lambda (x)
 		    byte-compile-bound-variables))))
 
 	((eq (car-safe spec) 'inline)
-	 (while (setq spec (cdr spec))
-	   (let ((assq (cdr (assq (car spec) byte-compile-macro-environment))))
-	     (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args)
-		      (atom (setq assq (nth 2 (nth 2 assq)))))
-		 ;; It's a label, and we're using the labels
-		 ;; implementation in bytecomp.el. Tell the compiler
-		 ;; to inline it, don't mark the symbol to be inlined
-		 ;; globally.
-		 (setf (getf (aref (compiled-function-constants assq) 0)
-                             'byte-optimizer)
-                       'byte-compile-inline-expand)
-	       (or (memq (get (car spec) 'byte-optimizer)
-			 '(nil byte-compile-inline-expand))
-		   (error
-		    "%s already has a byte-optimizer, can't make it inline"
-		    (car spec)))
-	       (put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))))
+         (while (setq spec (cdr spec))
+           (let* ((assq (cdr (assq (car spec)
+                                   byte-compile-macro-environment)))
+                  (symbol (if (and (consp assq)
+                                   (eq (nth 1 (nth 1 assq))
+                                       'byte-compile-labels-args))
+                              ;; It's a label, and we're using the labels
+                              ;; implementation in bytecomp.el. Tell the
+                              ;; compiler to inline it, don't mark the
+                              ;; symbol to be inlined globally.
+                              (nth 1 (nth 1 (nth 3 assq)))
+                            (car spec))))
+             (or (memq (get symbol 'byte-optimizer)
+                       '(nil byte-compile-inline-expand))
+                 (error
+                  "%s already has a byte-optimizer, can't make it inline"
+                  symbol))
+             (put symbol 'byte-optimizer 'byte-compile-inline-expand))))
 	((eq (car-safe spec) 'notinline)
 	 (while (setq spec (cdr spec))
-	   (let ((assq (cdr (assq (car spec) byte-compile-macro-environment))))
-	     (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args)
-		      (atom (setq assq (nth 2 (nth 2 assq)))))
-		 ;; It's a label, and we're using the labels
-		 ;; implementation in bytecomp.el. Tell the compiler
-		 ;; not to inline it.
-                 (if (eq 'byte-compile-inline-expand
-                         (getf (aref (compiled-function-constants assq) 0)
-                               'byte-optimizer))
-                     (remf (aref (compiled-function-constants assq) 0)
-                           'byte-optimizer))
-	       (if (eq (get (car spec) 'byte-optimizer)
-		       'byte-compile-inline-expand)
-		   (put (car spec) 'byte-optimizer nil))))))
+           (let* ((assq (cdr (assq (car spec)
+                                   byte-compile-macro-environment)))
+                  (symbol (if (and (consp assq)
+                                   (eq (nth 1 (nth 1 assq))
+                                       'byte-compile-labels-args))
+                              ;; It's a label, and we're using the labels
+                              ;; implementation in bytecomp.el. Tell the
+                              ;; compiler not to inline it, don't mark the
+                              ;; symbol to be notinline globally.
+                              (nth 1 (nth 1 (nth 3 assq)))
+                            (car spec))))
+             (if (eq (get symbol 'byte-optimizer)
+                     'byte-compile-inline-expand)
+                 (put symbol 'byte-optimizer nil)))))
 	((eq (car-safe spec) 'optimize)
 	 (let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
 			    '((0 . nil) (1 . t) (2 . t) (3 . t))))
 	   (if (consp (car spec))
 	       (if (eq (cadar spec) 0)
 		   (setq byte-compile-warnings
-			 (delq (caar spec) byte-compile-warnings))
+			 (delete* (caar spec) byte-compile-warnings))
 		 (setq byte-compile-warnings
 		       (adjoin (caar spec) byte-compile-warnings)))))))
   nil)
 ;;;###autoload
 (defun cl-do-pop (place)
   (if (cl-simple-expr-p place)
-      (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))
+      (list 'prog1 (list 'car-safe place) (list 'setf place (list 'cdr place)))
     (let* ((method (cl-setf-do-modify place t))
 	   (temp (gensym "--pop--")))
       (list 'let*
 	    (append (car method)
 		    (list (list temp (nth 2 method))))
 	    (list 'prog1
-		  (list 'car temp)
+		  (list 'car-safe temp)
 		  (cl-setf-do-store (nth 1 method) (list 'cdr temp)))))))
 
 ;;;###autoload
 				     (caar include-descs) include))
 			  old-descs)
 		    (pop include-descs)))
-	  (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
+	  (setq descs (append old-descs (delete* (assq 'cl-tag-slot descs) descs))
 		type (car inc-type)
 		named (assq 'cl-tag-slot descs))
 	  (if (cadr inc-type) (setq tag name named t))
 		(error "Illegal :type specifier: %s" type))
 	    (if named (setq tag name)))
 	(setq type 'vector named 'true)))
-    (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
+    (or named (setq descs (delete* (assq 'cl-tag-slot descs) descs)))
     (push (list 'defvar tag-symbol) forms)
     (setq pred-form (and named
 			 (let ((pos (- (length descs)
 		(push (cons copier t) side-eff)))
     (if constructor
 	(push (list constructor
-		       (cons '&key (delq nil (copy-sequence slots))))
-		 constrs))
+                    (cons '&key (remove* nil slots)))
+              constrs))
     (while constrs
       (let* ((name (caar constrs))
 	     (args (cadr (pop constrs)))
 	   (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler)
 					 (cdr type))))
 	  ((memq (car-safe type) '(integer float real number))
-	   (delq t (list 'and (cl-make-type-test val (car type))
+	   (delete* t (list 'and (cl-make-type-test val (car type))
 			 (if (memq (cadr type) '(* nil)) t
 			   (if (consp (cadr type)) (list '> val (caadr type))
 			     (list '>= val (cadr type))))
   (list 'eval-when '(compile load eval)
 	(cl-transform-function-property
 	 func 'cl-compiler-macro
-	 (cons (if (memq '&whole args) (delq '&whole args)
+	 (cons (if (memq '&whole args) (delete* '&whole args)
 		 (cons '--cl-whole-arg-- args)) body))
 	(list 'or (list 'get (list 'quote func) '(quote byte-compile))
 	      (list 'put (list 'quote func) '(quote byte-compile)
     ((most-positive-fixnum-on-32-bit-machines () (1- (lsh 1 30)))
      (most-negative-fixnum-on-32-bit-machines ()
        (lognot (most-positive-fixnum-on-32-bit-machines))))
-  (defun cl-non-fixnum-number-p (object)
+  (defun cl-non-immediate-number-p (object)
     "Return t if OBJECT is a number not guaranteed to be immediate."
     (and (numberp object)
 	 (or (not (fixnump object))
 (define-compiler-macro eql (&whole form a b)
   (cond ((eq (cl-const-expr-p a) t)
 	 (let ((val (cl-const-expr-val a)))
-	   (if (cl-non-fixnum-number-p val)
+	   (if (cl-non-immediate-number-p val)
 	       (list 'equal a b)
 	     (list 'eq a b))))
 	((eq (cl-const-expr-p b) t)
 	 (let ((val (cl-const-expr-val b)))
-	   (if (cl-non-fixnum-number-p val)
+	   (if (cl-non-immediate-number-p val)
 	       (list 'equal a b)
 	     (list 'eq a b))))
 	(t form)))
 
+(defun cl-equal-equivalent-to-eq-p (object)
+  (or (symbolp object) (characterp object)
+      (and (fixnump object) (not (cl-non-immediate-number-p object)))))
+
+(defun cl-car-or-pi (object)
+  (if (consp object) (car object) pi))
+
+(defun cl-cdr-or-pi (object)
+  (if (consp object) (cdr object) pi))
+
+(define-compiler-macro equal (&whole form a b)
+  (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val a pi))
+          (cl-equal-equivalent-to-eq-p (cl-const-expr-val b pi)))
+      (cons 'eq (cdr form))
+    form))
+
+(define-compiler-macro member (&whole form elt list)
+  (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi))
+          (every #'cl-equal-equivalent-to-eq-p
+                 (cl-const-expr-val list '(1.0))))
+      (cons 'memq (cdr form))
+    form))
+
+(define-compiler-macro assoc (&whole form elt list)
+  (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi))
+          (not (find-if-not #'cl-equal-equivalent-to-eq-p
+                            (cl-const-expr-val list '((1.0 . nil)))
+                            :key #'cl-car-or-pi)))
+      (cons 'assq (cdr form))
+    form))
+
+(define-compiler-macro rassoc (&whole form elt list)
+  (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi))
+          (not (find-if-not #'cl-equal-equivalent-to-eq-p
+                            (cl-const-expr-val list '((nil . 1.0)))
+                            :key #'cl-cdr-or-pi)))
+      (cons 'rassq (cdr form))
+    form))
+
 (macrolet
     ((define-star-compiler-macros (&rest macros)
        "For `member*', `assoc*' and `rassoc*' with constant ITEM or
                                  `(,',equal-function ,item ,list))
                                 ((and (eq test 'eql)
                                       (not (eq not-constant item-val)))
-                                 (if (cl-non-fixnum-number-p item-val)
+                                 (if (cl-non-immediate-number-p item-val)
                                      `(,',equal-function ,item ,list)
                                    `(,',eq-function ,item ,list)))
                                 ((and (eq test 'eql) (not (eq not-constant
                                                               list-val)))
-                                 (if (some 'cl-non-fixnum-number-p list-val)
+                                 (if (some 'cl-non-immediate-number-p list-val)
                                      `(,',equal-function ,item ,list)
                                    ;; This compiler macro used to limit
                                    ;; calls to ,,eq-function to lists where
           ((not-constant '#:not-constant))
         (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
           (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
-                   (not (cl-non-fixnum-number-p cl-const-expr-val)))
+                   (not (cl-non-immediate-number-p cl-const-expr-val)))
               (cons 'delete* (cdr form))
             `(delete* ,@(cdr form) :test #'eq))))
     form))
           ((not-constant '#:not-constant))
         (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
           (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
-                   (not (cl-non-fixnum-number-p cl-const-expr-val)))
+                   (not (cl-non-immediate-number-p cl-const-expr-val)))
               (cons 'remove* (cdr form))
             `(remove* ,@(cdr form) :test #'eq))))
     form))
 		(cl-seq begin))
 	  (while cl-seq
 	    (setq cl-seq (setcdr cl-seq
-				 (delq (car cl-seq) (cdr cl-seq)))))
+				 (delete* (car cl-seq) (cdr cl-seq)))))
 	  begin))
        ((or (plists-equal cl-keys '(:test 'equal) t)
 	    (plists-equal cl-keys '(:test #'equal) t))
   (list 'progn form))
 
 ;;;###autoload
-(defmacro labels (bindings &rest body)
+(defmacro* labels (bindings &rest body &environment env)
   "Make temporary function bindings.
 
 This is like `flet', except the bindings are lexical instead of dynamic.
   ;; XEmacs; the byte-compiler has a much better implementation of `labels'
   ;; in `byte-compile-initial-macro-environment' that is used in compiled
   ;; code.
-  (let ((vars nil) (sets nil)
-        (byte-compile-macro-environment byte-compile-macro-environment))
+  (let ((vars nil) (sets nil))
     (while bindings
       (let ((var (gensym)))
 	(push var vars)
 	(push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
 		       (list 'list* '(quote funcall) (list 'quote var)
 			     'cl-labels-args))
-		 byte-compile-macro-environment)))
-    (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
-			byte-compile-macro-environment)))
+              env)))
+    (cl-macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) env)))
 
 ;;;###autoload
 (defmacro flet (functions &rest form)
 careful about evaluating each argument only once and in the right order.
 PLACE may be a symbol, or any generalized variable allowed by `setf'."
   (if (symbolp place)
-      `(car (prog1 ,place (setq ,place (cdr ,place))))
+      `(car-safe (prog1 ,place (setq ,place (cdr ,place))))
     (cl-do-pop place)))
 
 (defmacro push (newelt listname)