X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/8121e4813da7e5898eb216a5de3c17f4875cac61..4d3b8872ad53ef6352f769df84c26b0f835ede3a:/lisp/emacs-lisp/cl-macs.el

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index d9d6658811..5b608f0093 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1,6 +1,6 @@
 ;;; cl-macs.el --- Common Lisp macros  -*- lexical-binding: t; coding: utf-8 -*-
 
-;; Copyright (C) 1993, 2001-2013 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2014 Free Software Foundation, Inc.
 
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;; Old-Version: 2.02
@@ -89,10 +89,11 @@
 ;; These are used by various
 ;; macro expanders to optimize the results in certain common cases.
 
-(defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
-			    car-safe cdr-safe progn prog1 prog2))
-(defconst cl--safe-funcs '(* / % length memq list vector vectorp
-			  < > <= >= = error))
+(eval-and-compile
+ (defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
+                                  car-safe cdr-safe progn prog1 prog2))
+ (defconst cl--safe-funcs '(* / % length memq list vector vectorp
+                              < > <= >= = error)))
 
 (defun cl--simple-expr-p (x &optional size)
   "Check if no side effects, and executes quickly."
@@ -113,16 +114,17 @@
     (setq xs (cdr xs)))
   (not xs))
 
-(defun cl--safe-expr-p (x)
-  "Check if no side effects."
-  (or (not (and (consp x) (not (memq (car x) '(quote function cl-function)))))
-      (and (symbolp (car x))
-	   (or (memq (car x) cl--simple-funcs)
-	       (memq (car x) cl--safe-funcs)
-	       (get (car x) 'side-effect-free))
-	   (progn
-	     (while (and (setq x (cdr x)) (cl--safe-expr-p (car x))))
-	     (null x)))))
+(eval-and-compile
+ (defun cl--safe-expr-p (x)
+   "Check if no side effects."
+   (or (not (and (consp x) (not (memq (car x) '(quote function cl-function)))))
+       (and (symbolp (car x))
+            (or (memq (car x) cl--simple-funcs)
+                (memq (car x) cl--safe-funcs)
+                (get (car x) 'side-effect-free))
+            (progn
+              (while (and (setq x (cdr x)) (cl--safe-expr-p (car x))))
+              (null x))))))
 
 ;;; Check if constant (i.e., no side effects or dependencies).
 (defun cl--const-expr-p (x)
@@ -135,22 +137,29 @@
 	(t t)))
 
 (defun cl--const-expr-val (x)
-  (and (macroexp-const-p x) (if (consp x) (nth 1 x) x)))
-
-(defun cl--expr-contains (x y)
-  "Count number of times X refers to Y.  Return nil for 0 times."
-  ;; FIXME: This is naive, and it will cl-count Y as referred twice in
-  ;; (let ((Y 1)) Y) even though it should be 0.  Also it is often called on
-  ;; non-macroexpanded code, so it may also miss some occurrences that would
-  ;; only appear in the expanded code.
-  (cond ((equal y x) 1)
-	((and (consp x) (not (memq (car x) '(quote function cl-function))))
-	 (let ((sum 0))
-	   (while (consp x)
-	     (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0))))
-	   (setq sum (+ sum (or (cl--expr-contains x y) 0)))
-	   (and (> sum 0) sum)))
-	(t nil)))
+  "Return the value of X known at compile-time.
+If X is not known at compile time, return nil.  Before testing
+whether X is known at compile time, macroexpand it completely in
+`macroexpand-all-environment'."
+  (let ((x (macroexpand-all x macroexpand-all-environment)))
+    (if (macroexp-const-p x)
+        (if (consp x) (nth 1 x) x))))
+
+(eval-and-compile
+ (defun cl--expr-contains (x y)
+   "Count number of times X refers to Y.  Return nil for 0 times."
+   ;; FIXME: This is naive, and it will cl-count Y as referred twice in
+   ;; (let ((Y 1)) Y) even though it should be 0.  Also it is often called on
+   ;; non-macroexpanded code, so it may also miss some occurrences that would
+   ;; only appear in the expanded code.
+   (cond ((equal y x) 1)
+         ((and (consp x) (not (memq (car x) '(quote function cl-function))))
+          (let ((sum 0))
+            (while (consp x)
+              (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0))))
+            (setq sum (+ sum (or (cl--expr-contains x y) 0)))
+            (and (> sum 0) sum)))
+         (t nil))))
 
 (defun cl--expr-contains-any (x y)
   (while (and y (not (cl--expr-contains x (car y)))) (pop y))
@@ -209,71 +218,75 @@ The name is made by appending a number to PREFIX, default \"G\"."
 (def-edebug-spec cl-&key-arg
   (&or ([&or (symbolp arg) arg] &optional def-form arg) arg))
 
-(defconst cl--lambda-list-keywords
-  '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
+(def-edebug-spec cl-type-spec sexp)
+
+(eval-and-compile
+  (defconst cl--lambda-list-keywords
+    '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
 
-(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
-(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)
+  (defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
+  (defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms))
 
-(defun cl--transform-lambda (form bind-block)
-  "Transform a function form FORM of name BIND-BLOCK.
+(eval-and-compile
+ (defun cl--transform-lambda (form bind-block)
+   "Transform a function form FORM of name BIND-BLOCK.
 BIND-BLOCK is the name of the symbol to which the function will be bound,
 and which will be used for the name of the `cl-block' surrounding the
 function's body.
 FORM is of the form (ARGS . BODY)."
-  (let* ((args (car form)) (body (cdr form)) (orig-args args)
-	 (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
-	 (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
-	 (header nil) (simple-args nil))
-    (while (or (stringp (car body))
-	       (memq (car-safe (car body)) '(interactive declare cl-declare)))
-      (push (pop body) header))
-    (setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
-    (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
-    (if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
-	(setq args (delq '&cl-defs (delq cl--bind-defs args))
-	      cl--bind-defs (cadr cl--bind-defs)))
-    (if (setq cl--bind-enquote (memq '&cl-quote args))
-	(setq args (delq '&cl-quote args)))
-    (if (memq '&whole args) (error "&whole not currently implemented"))
-    (let* ((p (memq '&environment args)) (v (cadr p))
-           (env-exp 'macroexpand-all-environment))
-      (if p (setq args (nconc (delq (car p) (delq v args))
-                              (list '&aux (list v env-exp))))))
-    (while (and args (symbolp (car args))
-		(not (memq (car args) '(nil &rest &body &key &aux)))
-		(not (and (eq (car args) '&optional)
-			  (or cl--bind-defs (consp (cadr args))))))
-      (push (pop args) simple-args))
-    (or (eq cl--bind-block 'cl-none)
-	(setq body (list `(cl-block ,cl--bind-block ,@body))))
-    (if (null args)
-	(cl-list* nil (nreverse simple-args) (nconc (nreverse 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 cl--bind-lets (nreverse cl--bind-lets))
-      (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
-                                ,@(nreverse cl--bind-inits)))
-	     (nconc (nreverse simple-args)
-		    (list '&rest (car (pop cl--bind-lets))))
-	     (nconc (let ((hdr (nreverse header)))
-                      ;; Macro expansion can take place in the middle of
-                      ;; apparently harmless computation, so it should not
-                      ;; touch the match-data.
-                      (save-match-data
-                        (require 'help-fns)
-                        (cons (help-add-fundoc-usage
-                               (if (stringp (car hdr)) (pop hdr))
-                               ;; Be careful with make-symbol and (back)quote,
-                               ;; see bug#12884.
-                               (let ((print-gensym nil) (print-quoted t))
-                                 (format "%S" (cons 'fn (cl--make-usage-args
-                                                         orig-args)))))
-                              hdr)))
-		    (list `(let* ,cl--bind-lets
-                             ,@(nreverse cl--bind-forms)
-                             ,@body)))))))
+   (let* ((args (car form)) (body (cdr form)) (orig-args args)
+          (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
+          (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
+          (header nil) (simple-args nil))
+     (while (or (stringp (car body))
+                (memq (car-safe (car body)) '(interactive declare cl-declare)))
+       (push (pop body) header))
+     (setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
+     (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
+     (if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
+         (setq args (delq '&cl-defs (delq cl--bind-defs args))
+               cl--bind-defs (cadr cl--bind-defs)))
+     (if (setq cl--bind-enquote (memq '&cl-quote args))
+         (setq args (delq '&cl-quote args)))
+     (if (memq '&whole args) (error "&whole not currently implemented"))
+     (let* ((p (memq '&environment args)) (v (cadr p))
+            (env-exp 'macroexpand-all-environment))
+       (if p (setq args (nconc (delq (car p) (delq v args))
+                               (list '&aux (list v env-exp))))))
+     (while (and args (symbolp (car args))
+                 (not (memq (car args) '(nil &rest &body &key &aux)))
+                 (not (and (eq (car args) '&optional)
+                           (or cl--bind-defs (consp (cadr args))))))
+       (push (pop args) simple-args))
+     (or (eq cl--bind-block 'cl-none)
+         (setq body (list `(cl-block ,cl--bind-block ,@body))))
+     (if (null args)
+         (cl-list* nil (nreverse simple-args) (nconc (nreverse 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 cl--bind-lets (nreverse cl--bind-lets))
+       (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
+                                        ,@(nreverse cl--bind-inits)))
+                 (nconc (nreverse simple-args)
+                        (list '&rest (car (pop cl--bind-lets))))
+                 (nconc (let ((hdr (nreverse header)))
+                          ;; Macro expansion can take place in the middle of
+                          ;; apparently harmless computation, so it should not
+                          ;; touch the match-data.
+                          (save-match-data
+                            (require 'help-fns)
+                            (cons (help-add-fundoc-usage
+                                   (if (stringp (car hdr)) (pop hdr))
+                                   ;; Be careful with make-symbol and (back)quote,
+                                   ;; see bug#12884.
+                                   (let ((print-gensym nil) (print-quoted t))
+                                     (format "%S" (cons 'fn (cl--make-usage-args
+                                                             orig-args)))))
+                                  hdr)))
+                        (list `(let* ,cl--bind-lets
+                                 ,@(nreverse cl--bind-forms)
+                                 ,@body))))))))
 
 ;;;###autoload
 (defmacro cl-defun (name args &rest body)
@@ -374,8 +387,6 @@ its argument list allows full Common Lisp conventions."
 	(if (car res) `(progn ,(car res) ,form) form))
     `(function ,func)))
 
-(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
-
 (defun cl--make-usage-var (x)
   "X can be a var or a (destructuring) lambda-list."
   (cond
@@ -501,7 +512,7 @@ its argument list allows full Common Lisp conventions."
 		   (varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
 		   (def (if (cdr arg) (cadr arg)
 			  (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs)))))
-		   (look `(memq ',karg ,restarg)))
+                   (look `(plist-member ,restarg ',karg)))
 	      (and def cl--bind-enquote (setq def `',def))
 	      (if (cddr arg)
 		  (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
@@ -547,17 +558,18 @@ its argument list allows full Common Lisp conventions."
 	    (cl--do-arglist (pop args) nil))))
       (if args (error "Malformed argument list %s" save-args)))))
 
-(defun cl--arglist-args (args)
-  (if (nlistp args) (list args)
-    (let ((res nil) (kind nil) arg)
-      (while (consp args)
-	(setq arg (pop args))
-	(if (memq arg cl--lambda-list-keywords) (setq kind arg)
-	  (if (eq arg '&cl-defs) (pop args)
-	    (and (consp arg) kind (setq arg (car arg)))
-	    (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
-	    (setq res (nconc res (cl--arglist-args arg))))))
-      (nconc res (and args (list args))))))
+(eval-and-compile
+ (defun cl--arglist-args (args)
+   (if (nlistp args) (list args)
+     (let ((res nil) (kind nil) arg)
+       (while (consp args)
+         (setq arg (pop args))
+         (if (memq arg cl--lambda-list-keywords) (setq kind arg)
+           (if (eq arg '&cl-defs) (pop args)
+             (and (consp arg) kind (setq arg (car arg)))
+             (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
+             (setq res (nconc res (cl--arglist-args arg))))))
+       (nconc res (and args (list args)))))))
 
 ;;;###autoload
 (defmacro cl-destructuring-bind (args expr &rest body)
@@ -753,14 +765,23 @@ This is compatible with Common Lisp, but note that `defun' and
 
 ;;; The "cl-loop" macro.
 
-(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars)
-(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-destr-temps)
-(defvar cl--loop-finally) (defvar cl--loop-finish-flag)
-(defvar cl--loop-first-flag)
-(defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name)
-(defvar cl--loop-result) (defvar cl--loop-result-explicit)
-(defvar cl--loop-result-var) (defvar cl--loop-steps)
-(defvar cl--loop-symbol-macs)
+(eval-and-compile
+ (defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars)
+ (defvar cl--loop-bindings) (defvar cl--loop-body)
+ (defvar cl--loop-finally)
+ (defvar cl--loop-finish-flag)    ;Symbol set to nil to exit the loop?
+ (defvar cl--loop-first-flag)
+ (defvar cl--loop-initially) (defvar cl--loop-iterator-function)
+ (defvar cl--loop-name)
+ (defvar cl--loop-result) (defvar cl--loop-result-explicit)
+ (defvar cl--loop-result-var) (defvar cl--loop-steps)
+ (defvar cl--loop-symbol-macs))
+
+(defun cl--loop-set-iterator-function (kind iterator)
+  (if cl--loop-iterator-function
+      ;; FIXME: Of course, we could make it work, but why bother.
+      (error "Iteration on %S does not support this combination" kind)
+    (setq cl--loop-iterator-function iterator)))
 
 ;;;###autoload
 (defmacro cl-loop (&rest loop-args)
@@ -815,13 +836,35 @@ For more details, see Info node `(cl)Loop Facility'.
                            (delq nil (delq t (cl-copy-list loop-args))))))
       `(cl-block nil (while t ,@loop-args))
     (let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil)
-	  (cl--loop-body nil)	(cl--loop-steps nil)
-	  (cl--loop-result nil)	(cl--loop-result-explicit nil)
-	  (cl--loop-result-var nil) (cl--loop-finish-flag nil)
+	  (cl--loop-body nil)		(cl--loop-steps nil)
+	  (cl--loop-result nil)		(cl--loop-result-explicit nil)
+	  (cl--loop-result-var nil)	(cl--loop-finish-flag nil)
 	  (cl--loop-accum-var nil)	(cl--loop-accum-vars nil)
 	  (cl--loop-initially nil)	(cl--loop-finally nil)
-	  (cl--loop-map-form nil)   (cl--loop-first-flag nil)
-	  (cl--loop-destr-temps nil) (cl--loop-symbol-macs nil))
+	  (cl--loop-iterator-function nil) (cl--loop-first-flag nil)
+          (cl--loop-symbol-macs nil))
+      ;; Here is more or less how those dynbind vars are used after looping
+      ;; over cl--parse-loop-clause:
+      ;;
+      ;; (cl-block ,cl--loop-name
+      ;;   (cl-symbol-macrolet ,cl--loop-symbol-macs
+      ;;     (foldl #'cl--loop-let
+      ;;            `((,cl--loop-result-var)
+      ;;              ((,cl--loop-first-flag t))
+      ;;              ((,cl--loop-finish-flag t))
+      ;;              ,@cl--loop-bindings)
+      ;;           ,@(nreverse cl--loop-initially)
+      ;;           (while                   ;(well: cl--loop-iterator-function)
+      ;;               ,(car (cl--loop-build-ands (nreverse cl--loop-body)))
+      ;;             ,@(cadr (cl--loop-build-ands (nreverse cl--loop-body)))
+      ;;             ,@(nreverse cl--loop-steps)
+      ;;             (setq ,cl--loop-first-flag nil))
+      ;;           (if (not ,cl--loop-finish-flag) ;FIXME: Why `if' vs `progn'?
+      ;;               ,cl--loop-result-var
+      ;;             ,@(nreverse cl--loop-finally)
+      ;;             ,(or cl--loop-result-explicit
+      ;;                  cl--loop-result)))))
+      ;;
       (setq cl--loop-args (append cl--loop-args '(cl-end-loop)))
       (while (not (eq (car cl--loop-args) 'cl-end-loop))
         (cl--parse-loop-clause))
@@ -837,15 +880,15 @@ For more details, see Info node `(cl)Loop Facility'.
 	     (while-body (nconc (cadr ands) (nreverse cl--loop-steps)))
 	     (body (append
 		    (nreverse cl--loop-initially)
-		    (list (if cl--loop-map-form
+		    (list (if cl--loop-iterator-function
 			      `(cl-block --cl-finish--
-                                 ,(cl-subst
-                                   (if (eq (car ands) t) while-body
-                                     (cons `(or ,(car ands)
-                                                (cl-return-from --cl-finish--
-                                                  nil))
-                                           while-body))
-                                   '--cl-map cl--loop-map-form))
+                                 ,(funcall cl--loop-iterator-function
+                                           (if (eq (car ands) t) while-body
+                                             (cons `(or ,(car ands)
+                                                        (cl-return-from
+                                                            --cl-finish--
+                                                          nil))
+                                                   while-body))))
 			    `(while ,(car ands) ,@while-body)))
 		    (if cl--loop-finish-flag
 			(if (equal epilogue '(nil)) (list cl--loop-result-var)
@@ -1214,15 +1257,18 @@ For more details, see Info node `(cl)Loop Facility'.
                           (make-symbol "--cl-var--"))))
 		  (if (memq word '(hash-value hash-values))
 		      (setq var (prog1 other (setq other var))))
-		  (setq cl--loop-map-form
-			`(maphash (lambda (,var ,other) . --cl-map) ,table))))
+		  (cl--loop-set-iterator-function
+                   'hash-tables (lambda (body)
+                                  `(maphash (lambda (,var ,other) . ,body)
+                                            ,table)))))
 
 	       ((memq word '(symbol present-symbol external-symbol
 			     symbols present-symbols external-symbols))
 		(let ((ob (and (memq (car cl--loop-args) '(in of))
                                (cl--pop2 cl--loop-args))))
-		  (setq cl--loop-map-form
-			`(mapatoms (lambda (,var) . --cl-map) ,ob))))
+		  (cl--loop-set-iterator-function
+                   'symbols (lambda (body)
+                              `(mapatoms (lambda (,var) . ,body) ,ob)))))
 
 	       ((memq word '(overlay overlays extent extents))
 		(let ((buf nil) (from nil) (to nil))
@@ -1232,11 +1278,12 @@ For more details, see Info node `(cl)Loop Facility'.
 			  ((eq (car cl--loop-args) 'to)
                            (setq to (cl--pop2 cl--loop-args)))
 			  (t (setq buf (cl--pop2 cl--loop-args)))))
-		  (setq cl--loop-map-form
-			`(cl--map-overlays
-			  (lambda (,var ,(make-symbol "--cl-var--"))
-			    (progn . --cl-map) nil)
-			  ,buf ,from ,to))))
+		  (cl--loop-set-iterator-function
+                   'overlays (lambda (body)
+                               `(cl--map-overlays
+                                 (lambda (,var ,(make-symbol "--cl-var--"))
+                                   (progn . ,body) nil)
+                                 ,buf ,from ,to)))))
 
 	       ((memq word '(interval intervals))
 		(let ((buf nil) (prop nil) (from nil) (to nil)
@@ -1253,10 +1300,11 @@ For more details, see Info node `(cl)Loop Facility'.
 		  (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
 		      (setq var1 (car var) var2 (cdr var))
 		    (push (list var `(cons ,var1 ,var2)) loop-for-sets))
-		  (setq cl--loop-map-form
-			`(cl--map-intervals
-			  (lambda (,var1 ,var2) . --cl-map)
-			  ,buf ,prop ,from ,to))))
+		  (cl--loop-set-iterator-function
+                   'intervals (lambda (body)
+                                `(cl--map-intervals
+                                  (lambda (,var1 ,var2) . ,body)
+                                  ,buf ,prop ,from ,to)))))
 
 	       ((memq word key-types)
 		(or (memq (car cl--loop-args) '(in of))
@@ -1272,10 +1320,11 @@ For more details, see Info node `(cl)Loop Facility'.
                          (make-symbol "--cl-var--"))))
 		  (if (memq word '(key-binding key-bindings))
 		      (setq var (prog1 other (setq other var))))
-		  (setq cl--loop-map-form
-			`(,(if (memq word '(key-seq key-seqs))
-			       'cl--map-keymap-recursively 'map-keymap)
-			  (lambda (,var ,other) . --cl-map) ,cl-map))))
+		  (cl--loop-set-iterator-function
+                   'keys (lambda (body)
+                           `(,(if (memq word '(key-seq key-seqs))
+                                  'cl--map-keymap-recursively 'map-keymap)
+                             (lambda (,var ,other) . ,body) ,cl-map)))))
 
 	       ((memq word '(frame frames screen screens))
 		(let ((temp (make-symbol "--cl-var--")))
@@ -1446,12 +1495,9 @@ For more details, see Info node `(cl)Loop Facility'.
 	(if (eq word 'unless) (setq then (prog1 else (setq else then))))
 	(let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
 			  (if simple (nth 1 else) (list (nth 2 else))))))
-	  (if (cl--expr-contains form 'it)
-	      (let ((temp (make-symbol "--cl-var--")))
-		(push (list temp) cl--loop-bindings)
-		(setq form `(if (setq ,temp ,cond)
-                                ,@(cl-subst temp 'it form))))
-	    (setq form `(if ,cond ,@form)))
+	  (setq form (if (cl--expr-contains form 'it)
+                         `(let ((it ,cond)) (if it ,@form))
+                       `(if ,cond ,@form)))
 	  (push (if simple `(progn ,form t) form) cl--loop-body))))
 
      ((memq word '(do doing))
@@ -1476,36 +1522,52 @@ For more details, see Info node `(cl)Loop Facility'.
     (if (eq (car cl--loop-args) 'and)
 	(progn (pop cl--loop-args) (cl--parse-loop-clause)))))
 
-(defun cl--loop-let (specs body par)   ; uses loop-*
-  (let ((p specs) (temps nil) (new nil))
-    (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p))))
-      (setq p (cdr p)))
-    (and par p
-	 (progn
-	   (setq par nil p specs)
-	   (while p
-	     (or (macroexp-const-p (cl-cadar p))
-		 (let ((temp (make-symbol "--cl-var--")))
-		   (push (list temp (cl-cadar p)) temps)
-		   (setcar (cdar p) temp)))
-	     (setq p (cdr p)))))
+(defun cl--unused-var-p (sym)
+  (or (null sym) (eq ?_ (aref (symbol-name sym) 0))))
+
+(defun cl--loop-let (specs body par)    ; modifies cl--loop-bindings
+  "Build an expression equivalent to (let SPECS BODY).
+SPECS can include bindings using `cl-loop's destructuring (not to be
+confused with the patterns of `cl-destructuring-bind').
+If PAR is nil, do the bindings step by step, like `let*'.
+If BODY is `setq', then use SPECS for assignments rather than for bindings."
+  (let ((temps nil) (new nil))
+    (when par
+      (let ((p specs))
+        (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p))))
+          (setq p (cdr p)))
+        (when p
+          (setq par nil)
+          (dolist (spec specs)
+            (or (macroexp-const-p (cadr spec))
+                (let ((temp (make-symbol "--cl-var--")))
+                  (push (list temp (cadr spec)) temps)
+                  (setcar (cdr spec) temp)))))))
     (while specs
-      (if (and (consp (car specs)) (listp (caar specs)))
-	  (let* ((spec (caar specs)) (nspecs nil)
-		 (expr (cadr (pop specs)))
-		 (temp
-                  (cdr (or (assq spec cl--loop-destr-temps)
-                           (car (push (cons spec
-                                            (or (last spec 0)
-                                                (make-symbol "--cl-var--")))
-                                      cl--loop-destr-temps))))))
-	    (push (list temp expr) new)
-	    (while (consp spec)
-	      (push (list (pop spec)
-			     (and expr (list (if spec 'pop 'car) temp)))
-		       nspecs))
-	    (setq specs (nconc (nreverse nspecs) specs)))
-	(push (pop specs) new)))
+      (let* ((binding (pop specs))
+             (spec (car-safe binding)))
+        (if (and (consp binding) (or (consp spec) (cl--unused-var-p spec)))
+            (let* ((nspecs nil)
+                   (expr (car (cdr-safe binding)))
+                   (temp (last spec 0)))
+              (if (and (cl--unused-var-p temp) (null expr))
+                  nil ;; Don't bother declaring/setting `temp' since it won't
+		      ;; be used when `expr' is nil, anyway.
+		(when (or (null temp)
+                          (and (eq body 'setq) (cl--unused-var-p temp)))
+                  ;; Prefer a fresh uninterned symbol over "_to", to avoid
+                  ;; warnings that we set an unused variable.
+                  (setq temp (make-symbol "--cl-var--"))
+                  ;; Make sure this temp variable is locally declared.
+                  (when (eq body 'setq)
+                    (push (list (list temp)) cl--loop-bindings)))
+                (push (list temp expr) new))
+              (while (consp spec)
+                (push (list (pop spec)
+                            (and expr (list (if spec 'pop 'car) temp)))
+                      nspecs))
+              (setq specs (nconc (nreverse nspecs) specs)))
+          (push binding new))))
     (if (eq body 'setq)
 	(let ((set (cons (if par 'cl-psetq 'setq)
                          (apply 'nconc (nreverse new)))))
@@ -1829,13 +1891,13 @@ This is like `cl-flet', but for macros instead of functions.
              cl-declarations body)))
   (if (cdr bindings)
       `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body))
-    (if (null bindings) (cons 'progn body)
+    (if (null bindings) (macroexp-progn body)
       (let* ((name (caar bindings))
 	     (res (cl--transform-lambda (cdar bindings) name)))
 	(eval (car res))
-	(macroexpand-all (cons 'progn body)
-                         (cons (cons name `(lambda ,@(cdr res)))
-                               macroexpand-all-environment))))))
+	(macroexpand-all (macroexp-progn body)
+			 (cons (cons name `(lambda ,@(cdr res)))
+			       macroexpand-all-environment))))))
 
 (defconst cl--old-macroexpand
   (if (and (boundp 'cl--old-macroexpand)
@@ -1943,11 +2005,18 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
       (unwind-protect
           (progn
             (fset 'macroexpand #'cl--sm-macroexpand)
-            ;; FIXME: For N bindings, this will traverse `body' N times!
-            (macroexpand-all (cons 'progn body)
-                             (cons (list (symbol-name (caar bindings))
-                                         (cl-cadar bindings))
-                                   macroexpand-all-environment)))
+            (let ((expansion
+                   ;; FIXME: For N bindings, this will traverse `body' N times!
+                   (macroexpand-all (macroexp-progn body)
+                                    (cons (list (symbol-name (caar bindings))
+                                                (cl-cadar bindings))
+                                          macroexpand-all-environment))))
+              (if (or (null (cdar bindings)) (cl-cddar bindings))
+                  (macroexp--warn-and-return
+                   (format "Malformed `cl-symbol-macrolet' binding: %S"
+                           (car bindings))
+                   expansion)
+                expansion)))
         (fset 'macroexpand previous-macroexpand))))))
 
 ;;; Multiple values.
@@ -2001,10 +2070,21 @@ values.  For compatibility, (cl-values A B C) is a synonym for (list A B C).
   (declare (debug t))
   (cons 'progn body))
 ;;;###autoload
-(defmacro cl-the (_type form)
-  "At present this ignores TYPE and is simply equivalent to FORM."
+(defmacro cl-the (type form)
+  "Return FORM.  If type-checking is enabled, assert that it is of TYPE."
   (declare (indent 1) (debug (cl-type-spec form)))
-  form)
+  (if (not (or (not (cl--compiling-file))
+               (< cl--optimize-speed 3)
+               (= cl--optimize-safety 3)))
+      form
+    (let* ((temp (if (cl--simple-expr-p form 3)
+                     form (make-symbol "--cl-var--")))
+           (body `(progn (unless ,(cl--make-type-test temp type)
+                           (signal 'wrong-type-argument
+                                   (list ',type ,temp ',form)))
+                         ,temp)))
+      (if (eq temp form) body
+        `(let ((,temp ,form)) ,body)))))
 
 (defvar cl--proclaim-history t)    ; for future compilers
 (defvar cl--declare-stack t)       ; for future compilers
@@ -2516,21 +2596,49 @@ non-nil value, that slot cannot be set via `setf'.
              (put ',name 'cl-struct-include ',include)
              (put ',name 'cl-struct-print ,print-auto)
              ,@(mapcar (lambda (x)
-                         `(put ',(car x) 'side-effect-free ',(cdr x)))
+                         `(function-put ',(car x) 'side-effect-free ',(cdr x)))
                        side-eff))
           forms)
     `(progn ,@(nreverse (cons `',name forms)))))
 
-;;; Types and assertions.
-
-;;;###autoload
-(defmacro cl-deftype (name arglist &rest body)
-  "Define NAME as a new data type.
-The type name can then be used in `cl-typecase', `cl-check-type', etc."
-  (declare (debug cl-defmacro) (doc-string 3))
-  `(cl-eval-when (compile load eval)
-     (put ',name 'cl-deftype-handler
-          (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
+(defun cl-struct-sequence-type (struct-type)
+  "Return the sequence used to build STRUCT-TYPE.
+STRUCT-TYPE is a symbol naming a struct type.  Return 'vector or
+'list, or nil if STRUCT-TYPE is not a struct type. "
+  (declare (side-effect-free t) (pure t))
+  (car (get struct-type 'cl-struct-type)))
+
+(defun cl-struct-slot-info (struct-type)
+  "Return a list of slot names of struct STRUCT-TYPE.
+Each entry is a list (SLOT-NAME . OPTS), where SLOT-NAME is a
+slot name symbol and OPTS is a list of slot options given to
+`cl-defstruct'.  Dummy slots that represent the struct name and
+slots skipped by :initial-offset may appear in the list."
+  (declare (side-effect-free t) (pure t))
+  (get struct-type 'cl-struct-slots))
+
+(defun cl-struct-slot-offset (struct-type slot-name)
+  "Return the offset of slot SLOT-NAME in STRUCT-TYPE.
+The returned zero-based slot index is relative to the start of
+the structure data type and is adjusted for any structure name
+and :initial-offset slots.  Signal error if struct STRUCT-TYPE
+does not contain SLOT-NAME."
+  (declare (side-effect-free t) (pure t))
+  (or (cl-position slot-name
+                   (cl-struct-slot-info struct-type)
+                   :key #'car :test #'eq)
+      (error "struct %s has no slot %s" struct-type slot-name)))
+
+(defvar byte-compile-function-environment)
+(defvar byte-compile-macro-environment)
+
+(defun cl--macroexp-fboundp (sym)
+  "Return non-nil if SYM will be bound when we run the code.
+Of course, we really can't know that for sure, so it's just a heuristic."
+  (or (fboundp sym)
+      (and (cl--compiling-file)
+           (or (cdr (assq sym byte-compile-function-environment))
+               (cdr (assq sym byte-compile-macro-environment))))))
 
 (defun cl--make-type-test (val type)
   (if (symbolp type)
@@ -2547,8 +2655,12 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc."
 	    (t
 	     (let* ((name (symbol-name type))
 		    (namep (intern (concat name "p"))))
-	       (if (fboundp namep) (list namep val)
-		 (list (intern (concat name "-p")) val)))))
+	       (cond
+                ((cl--macroexp-fboundp namep) (list namep val))
+                ((cl--macroexp-fboundp
+                  (setq namep (intern (concat name "-p"))))
+                 (list namep val))
+                (t (list type val))))))
     (cond ((get (car type) 'cl-deftype-handler)
 	   (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler)
 					 (cdr type))))
@@ -2639,7 +2751,7 @@ compiler macros are expanded repeatedly until no further expansions are
 possible.  Unlike regular macros, BODY can decide to \"punt\" and leave the
 original function call alone by declaring an initial `&whole foo' parameter
 and then returning foo."
-  (declare (debug cl-defmacro))
+  (declare (debug cl-defmacro) (indent 2))
   (let ((p args) (res nil))
     (while (consp p) (push (pop p) res))
     (setq args (nconc (nreverse res) (and p (list '&rest p)))))
@@ -2677,12 +2789,12 @@ macro that returns its `&whole' argument."
   (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
          (cl--active-block-names (cons cl-entry cl--active-block-names))
          (cl-body (macroexpand-all      ;Performs compiler-macro expansions.
-                   (cons 'progn (cddr cl-form))
+                   (macroexp-progn (cddr cl-form))
                    macroexpand-all-environment)))
     ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
     ;; to indicate that this return value is already fully expanded.
     (if (cdr cl-entry)
-        `(catch ,(nth 1 cl-form) ,@(cdr cl-body))
+        `(catch ,(nth 1 cl-form) ,@(macroexp-unprogn cl-body))
       cl-body)))
 
 (cl-define-compiler-macro cl--block-throw (cl-tag cl-value)
@@ -2693,15 +2805,18 @@ macro that returns its `&whole' argument."
 ;;;###autoload
 (defmacro cl-defsubst (name args &rest body)
   "Define NAME as a function.
-Like `defun', except the function is automatically declared `inline',
+Like `defun', except the function is automatically declared `inline' and
+the arguments are immutable.
 ARGLIST allows full Common Lisp conventions, and BODY is implicitly
 surrounded by (cl-block NAME ...).
+The function's arguments should be treated as immutable.
 
 \(fn NAME ARGLIST [DOCSTRING] BODY...)"
   (declare (debug cl-defun) (indent 2))
-  (let* ((argns (cl--arglist-args args)) (p argns)
-	 (pbody (cons 'progn body))
-	 (unsafe (not (cl--safe-expr-p pbody))))
+  (let* ((argns (cl--arglist-args args))
+         (p argns)
+         ;; (pbody (cons 'progn body))
+         )
     (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p))
     `(progn
        ,(if p nil   ; give up if defaults refer to earlier args
@@ -2717,10 +2832,10 @@ surrounded by (cl-block NAME ...).
               ;; does not pay attention to the argvs (and
               ;; cl-expr-access-order itself is also too naive).
               nil
-              ,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns)))
+              ,(and (memq '&key args) 'cl-whole) nil ,@argns)))
        (cl-defun ,name ,args ,@body))))
 
-(defun cl--defsubst-expand (argns body simple whole unsafe &rest argvs)
+(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs)
   (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
     (if (cl--simple-exprs-p argvs) (setq simple t))
     (let* ((substs ())
@@ -2728,7 +2843,7 @@ surrounded by (cl-block NAME ...).
                        (cl-mapcar (lambda (argn argv)
                                     (if (or simple (macroexp-const-p argv))
                                         (progn (push (cons argn argv) substs)
-                                               (and unsafe (list argn argv)))
+                                               nil)
                                       (list argn argv)))
                                   argns argvs))))
       ;; FIXME: `sublis/subst' will happily substitute the symbol
@@ -2799,19 +2914,47 @@ surrounded by (cl-block NAME ...).
 
 ;;; Things that are inline.
 (cl-proclaim '(inline cl-acons cl-map cl-concatenate cl-notany
-               cl-notevery cl--set-elt cl-revappend cl-nreconc gethash))
+               cl-notevery cl-revappend cl-nreconc gethash))
 
 ;;; Things that are side-effect-free.
-(mapc (lambda (x) (put x 'side-effect-free t))
+(mapc (lambda (x) (function-put x 'side-effect-free t))
       '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd
         cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem
         cl-subseq cl-list-length cl-get cl-getf))
 
 ;;; Things that are side-effect-and-error-free.
-(mapc (lambda (x) (put x 'side-effect-free 'error-free))
+(mapc (lambda (x) (function-put x 'side-effect-free 'error-free))
       '(eql cl-list* cl-subst cl-acons cl-equalp
         cl-random-state-p copy-tree cl-sublis))
 
+;;; Types and assertions.
+
+;;;###autoload
+(defmacro cl-deftype (name arglist &rest body)
+  "Define NAME as a new data type.
+The type name can then be used in `cl-typecase', `cl-check-type', etc."
+  (declare (debug cl-defmacro) (doc-string 3) (indent 2))
+  `(cl-eval-when (compile load eval)
+     (put ',name 'cl-deftype-handler
+          (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
+
+;;; Additional functions that we can now define because we've defined
+;;; `cl-defsubst' and `cl-typep'.
+
+(cl-defsubst cl-struct-slot-value (struct-type slot-name inst)
+  ;; The use of `cl-defsubst' here gives us both a compiler-macro
+  ;; and a gv-expander "for free".
+  "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE.
+STRUCT and SLOT-NAME are symbols.  INST is a structure instance."
+  (declare (side-effect-free t))
+  (unless (cl-typep inst struct-type)
+    (signal 'wrong-type-argument (list struct-type inst)))
+  ;; We could use `elt', but since the byte compiler will resolve the
+  ;; branch below at compile time, it's more efficient to use the
+  ;; type-specific accessor.
+  (if (eq (cl-struct-sequence-type struct-type) 'vector)
+      (aref inst (cl-struct-slot-offset struct-type slot-name))
+    (nth (cl-struct-slot-offset struct-type slot-name) inst)))
 
 (run-hooks 'cl-macs-load-hook)