X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/26f8a384978c6b1d1db1c6b091fa1e51d9ff5a5b..ac16149ba470ae8a625d42a61adbb6e84254c675:/lisp/emacs-lisp/cl-macs.el

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 69f2792f4b..09d2d3f9a5 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1,4 +1,4 @@
-;;; cl-macs.el --- Common Lisp macros  -*- lexical-binding: t; coding: utf-8 -*-
+;;; cl-macs.el --- Common Lisp macros  -*- lexical-binding: t -*-
 
 ;; Copyright (C) 1993, 2001-2015 Free Software Foundation, Inc.
 
@@ -161,7 +161,7 @@ whether X is known at compile time, macroexpand it completely in
 
 ;;; Symbols.
 
-(defvar cl--gensym-counter)
+(defvar cl--gensym-counter 0)
 ;;;###autoload
 (defun cl-gensym (&optional prefix)
   "Generate a new uninterned symbol.
@@ -294,14 +294,14 @@ FORM is of the form (ARGS . BODY)."
                       ;; 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 header)) (pop header))
                                ;; 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)))))
+                               (help--docstring-quote
+                                (let ((print-gensym nil) (print-quoted t))
+                                  (format "%S" (cons 'fn (cl--make-usage-args
+                                                          orig-args))))))
                               header)))
                 ;; FIXME: we'd want to choose an arg name for the &rest param
                 ;; and pass that as `expr' to cl--do-arglist, but that ends up
@@ -1787,7 +1787,8 @@ Labels have lexical scope and dynamic extent."
       (unless (eq 'go (car-safe (car-safe block)))
         (push `(go cl--exit) block))
       (push (nreverse block) blocks))
-    (let ((catch-tag (make-symbol "cl--tagbody-tag")))
+    (let ((catch-tag (make-symbol "cl--tagbody-tag"))
+          (cl--tagbody-alist cl--tagbody-alist))
       (push (cons 'cl--exit catch-tag) cl--tagbody-alist)
       (dolist (block blocks)
         (push (cons (car block) catch-tag) cl--tagbody-alist))
@@ -2101,8 +2102,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
                                           macroexpand-all-environment))))
               (if (or (null (cdar bindings)) (cl-cddar bindings))
                   (macroexp--warn-and-return
-                   (format "Malformed `cl-symbol-macrolet' binding: %S"
-                           (car bindings))
+                   (format-message "Malformed `cl-symbol-macrolet' binding: %S"
+                                   (car bindings))
                    expansion)
                 expansion)))
         (fset 'macroexpand previous-macroexpand))))))
@@ -2722,16 +2723,16 @@ non-nil value, that slot cannot be set via `setf'.
          (push `(defalias ',copier #'copy-sequence) forms))
     (if constructor
 	(push (list constructor
-		       (cons '&key (delq nil (copy-sequence slots))))
-		 constrs))
-    (while constrs
-      (let* ((name (caar constrs))
-	     (args (cadr (pop constrs)))
-	     (anames (cl--arglist-args args))
+                    (cons '&key (delq nil (copy-sequence slots))))
+              constrs))
+    (pcase-dolist (`(,cname ,args ,doc) constrs)
+      (let* ((anames (cl--arglist-args args))
 	     (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
 			    slots defaults)))
-	(push `(cl-defsubst ,name
+	(push `(cl-defsubst ,cname
                    (&cl-defs (nil ,@descs) ,@args)
+                 ,(if (stringp doc) doc
+                    (format "Constructor for objects of type `%s'." name))
                  ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
                        '((declare (side-effect-free t))))
                  (,(or type #'vector) ,@make))
@@ -2777,9 +2778,10 @@ non-nil value, that slot cannot be set via `setf'.
 ;;;###autoload
 (pcase-defmacro cl-struct (type &rest fields)
   "Pcase patterns to match cl-structs.
-Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of
-field NAME is matched against UPAT, or they can be of the form NAME which
+Elements of FIELDS can be of the form (NAME PAT) in which case the contents of
+field NAME is matched against PAT, or they can be of the form NAME which
 is a shorthand for (NAME NAME)."
+  (declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp])))
   `(and (pred (pcase--flip cl-typep ',type))
         ,@(mapcar
            (lambda (field)
@@ -2828,8 +2830,8 @@ is a shorthand for (NAME NAME)."
 
 (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. "
+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))
   (cl--struct-class-type (cl--struct-get-class struct-type)))
 
@@ -2854,6 +2856,8 @@ slots skipped by :initial-offset may appear in the list."
               descs)))
     (nreverse descs)))
 
+(define-error 'cl-struct-unknown-slot "struct %S has no slot %S")
+
 (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
@@ -2863,7 +2867,7 @@ does not contain SLOT-NAME."
   (declare (side-effect-free t) (pure t))
   (or (gethash slot-name
                (cl--class-index-table (cl--struct-get-class struct-type)))
-      (error "struct %s has no slot %s" struct-type slot-name)))
+      (signal 'cl-struct-unknown-slot (list struct-type slot-name))))
 
 (defvar byte-compile-function-environment)
 (defvar byte-compile-macro-environment)