LCOV - code coverage report
Current view: top level - lisp/emacs-lisp - cl-extra.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 21 527 4.0 %
Date: 2017-08-30 10:12:24 Functions: 2 64 3.1 %

          Line data    Source code
       1             : ;;; cl-extra.el --- Common Lisp features, part 2  -*- lexical-binding: t -*-
       2             : 
       3             : ;; Copyright (C) 1993, 2000-2017 Free Software Foundation, Inc.
       4             : 
       5             : ;; Author: Dave Gillespie <daveg@synaptics.com>
       6             : ;; Keywords: extensions
       7             : ;; Package: emacs
       8             : 
       9             : ;; This file is part of GNU Emacs.
      10             : 
      11             : ;; GNU Emacs is free software: you can redistribute it and/or modify
      12             : ;; it under the terms of the GNU General Public License as published by
      13             : ;; the Free Software Foundation, either version 3 of the License, or
      14             : ;; (at your option) any later version.
      15             : 
      16             : ;; GNU Emacs is distributed in the hope that it will be useful,
      17             : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
      18             : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      19             : ;; GNU General Public License for more details.
      20             : 
      21             : ;; You should have received a copy of the GNU General Public License
      22             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      23             : 
      24             : ;;; Commentary:
      25             : 
      26             : ;; These are extensions to Emacs Lisp that provide a degree of
      27             : ;; Common Lisp compatibility, beyond what is already built-in
      28             : ;; in Emacs Lisp.
      29             : ;;
      30             : ;; This package was written by Dave Gillespie; it is a complete
      31             : ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
      32             : ;;
      33             : ;; Bug reports, comments, and suggestions are welcome!
      34             : 
      35             : ;; This file contains portions of the Common Lisp extensions
      36             : ;; package which are autoloaded since they are relatively obscure.
      37             : 
      38             : ;;; Code:
      39             : 
      40             : (require 'cl-lib)
      41             : 
      42             : ;;; Type coercion.
      43             : 
      44             : ;;;###autoload
      45             : (defun cl-coerce (x type)
      46             :   "Coerce OBJECT to type TYPE.
      47             : TYPE is a Common Lisp type specifier.
      48             : \n(fn OBJECT TYPE)"
      49           1 :   (cond ((eq type 'list) (if (listp x) x (append x nil)))
      50           1 :         ((eq type 'vector) (if (vectorp x) x (vconcat x)))
      51           0 :         ((eq type 'string) (if (stringp x) x (concat x)))
      52           0 :         ((eq type 'array) (if (arrayp x) x (vconcat x)))
      53           0 :         ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
      54           0 :         ((and (eq type 'character) (symbolp x))
      55           0 :          (cl-coerce (symbol-name x) type))
      56           0 :         ((eq type 'float) (float x))
      57           0 :         ((cl-typep x type) x)
      58           1 :         (t (error "Can't coerce %s to type %s" x type))))
      59             : 
      60             : 
      61             : ;;; Predicates.
      62             : 
      63             : ;;;###autoload
      64             : (defun cl-equalp (x y)
      65             :   "Return t if two Lisp objects have similar structures and contents.
      66             : This is like `equal', except that it accepts numerically equal
      67             : numbers of different types (float vs. integer), and also compares
      68             : strings case-insensitively."
      69           0 :   (cond ((eq x y) t)
      70           0 :         ((stringp x)
      71           0 :          (and (stringp y) (= (length x) (length y))
      72           0 :               (or (string-equal x y)
      73           0 :                   (string-equal (downcase x) (downcase y))))) ;Lazy but simple!
      74           0 :         ((numberp x)
      75           0 :          (and (numberp y) (= x y)))
      76           0 :         ((consp x)
      77           0 :          (while (and (consp x) (consp y) (cl-equalp (car x) (car y)))
      78           0 :            (setq x (cdr x) y (cdr y)))
      79           0 :          (and (not (consp x)) (cl-equalp x y)))
      80           0 :         ((vectorp x)
      81           0 :          (and (vectorp y) (= (length x) (length y))
      82           0 :               (let ((i (length x)))
      83           0 :                 (while (and (>= (setq i (1- i)) 0)
      84           0 :                             (cl-equalp (aref x i) (aref y i))))
      85           0 :                 (< i 0))))
      86           0 :         (t (equal x y))))
      87             : 
      88             : 
      89             : ;;; Control structures.
      90             : 
      91             : ;;;###autoload
      92             : (defun cl--mapcar-many (cl-func cl-seqs &optional acc)
      93           0 :   (if (cdr (cdr cl-seqs))
      94           0 :       (let* ((cl-res nil)
      95           0 :              (cl-n (apply 'min (mapcar 'length cl-seqs)))
      96             :              (cl-i 0)
      97           0 :              (cl-args (copy-sequence cl-seqs))
      98             :              cl-p1 cl-p2)
      99           0 :         (setq cl-seqs (copy-sequence cl-seqs))
     100           0 :         (while (< cl-i cl-n)
     101           0 :           (setq cl-p1 cl-seqs cl-p2 cl-args)
     102           0 :           (while cl-p1
     103           0 :             (setcar cl-p2
     104           0 :                     (if (consp (car cl-p1))
     105           0 :                         (prog1 (car (car cl-p1))
     106           0 :                           (setcar cl-p1 (cdr (car cl-p1))))
     107           0 :                       (aref (car cl-p1) cl-i)))
     108           0 :             (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))
     109           0 :           (if acc
     110           0 :               (push (apply cl-func cl-args) cl-res)
     111           0 :             (apply cl-func cl-args))
     112           0 :           (setq cl-i (1+ cl-i)))
     113           0 :         (and acc (nreverse cl-res)))
     114           0 :     (let ((cl-res nil)
     115           0 :           (cl-x (car cl-seqs))
     116           0 :           (cl-y (nth 1 cl-seqs)))
     117           0 :       (let ((cl-n (min (length cl-x) (length cl-y)))
     118             :             (cl-i -1))
     119           0 :         (while (< (setq cl-i (1+ cl-i)) cl-n)
     120           0 :           (let ((val (funcall cl-func
     121           0 :                               (if (consp cl-x) (pop cl-x) (aref cl-x cl-i))
     122           0 :                               (if (consp cl-y) (pop cl-y) (aref cl-y cl-i)))))
     123           0 :             (when acc
     124           0 :               (push val cl-res)))))
     125           0 :         (and acc (nreverse cl-res)))))
     126             : 
     127             : ;;;###autoload
     128             : (defun cl-map (cl-type cl-func cl-seq &rest cl-rest)
     129             :   "Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
     130             : TYPE is the sequence type to return.
     131             : \n(fn TYPE FUNCTION SEQUENCE...)"
     132           0 :   (let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest)))
     133           0 :     (and cl-type (cl-coerce cl-res cl-type))))
     134             : 
     135             : ;;;###autoload
     136             : (defun cl-maplist (cl-func cl-list &rest cl-rest)
     137             :   "Map FUNCTION to each sublist of LIST or LISTs.
     138             : Like `cl-mapcar', except applies to lists and their cdr's rather than to
     139             : the elements themselves.
     140             : \n(fn FUNCTION LIST...)"
     141           0 :   (if cl-rest
     142           0 :       (let ((cl-res nil)
     143           0 :             (cl-args (cons cl-list (copy-sequence cl-rest)))
     144             :             cl-p)
     145           0 :         (while (not (memq nil cl-args))
     146           0 :           (push (apply cl-func cl-args) cl-res)
     147           0 :           (setq cl-p cl-args)
     148           0 :           (while cl-p (setcar cl-p (cdr (pop cl-p)))))
     149           0 :         (nreverse cl-res))
     150           0 :     (let ((cl-res nil))
     151           0 :       (while cl-list
     152           0 :         (push (funcall cl-func cl-list) cl-res)
     153           0 :         (setq cl-list (cdr cl-list)))
     154           0 :       (nreverse cl-res))))
     155             : 
     156             : ;;;###autoload
     157             : (defun cl-mapc (cl-func cl-seq &rest cl-rest)
     158             :   "Like `cl-mapcar', but does not accumulate values returned by the function.
     159             : \n(fn FUNCTION SEQUENCE...)"
     160           0 :   (if cl-rest
     161           0 :       (if (or (cdr cl-rest) (nlistp cl-seq) (nlistp (car cl-rest)))
     162           0 :           (progn
     163           0 :             (cl--mapcar-many cl-func (cons cl-seq cl-rest))
     164           0 :             cl-seq)
     165           0 :         (let ((cl-x cl-seq) (cl-y (car cl-rest)))
     166           0 :           (while (and cl-x cl-y)
     167           0 :             (funcall cl-func (pop cl-x) (pop cl-y)))
     168           0 :           cl-seq))
     169           0 :     (mapc cl-func cl-seq)))
     170             : 
     171             : ;;;###autoload
     172             : (defun cl-mapl (cl-func cl-list &rest cl-rest)
     173             :   "Like `cl-maplist', but does not accumulate values returned by the function.
     174             : \n(fn FUNCTION LIST...)"
     175           0 :   (if cl-rest
     176           0 :       (let ((cl-args (cons cl-list (copy-sequence cl-rest)))
     177             :             cl-p)
     178           0 :         (while (not (memq nil cl-args))
     179           0 :           (apply cl-func cl-args)
     180           0 :           (setq cl-p cl-args)
     181           0 :           (while cl-p (setcar cl-p (cdr (pop cl-p))))))
     182           0 :     (let ((cl-p cl-list))
     183           0 :       (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
     184           0 :   cl-list)
     185             : 
     186             : ;;;###autoload
     187             : (defun cl-mapcan (cl-func cl-seq &rest cl-rest)
     188             :   "Like `cl-mapcar', but nconc's together the values returned by the function.
     189             : \n(fn FUNCTION SEQUENCE...)"
     190           0 :   (if cl-rest
     191           0 :       (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))
     192           0 :     (mapcan cl-func cl-seq)))
     193             : 
     194             : ;;;###autoload
     195             : (defun cl-mapcon (cl-func cl-list &rest cl-rest)
     196             :   "Like `cl-maplist', but nconc's together the values returned by the function.
     197             : \n(fn FUNCTION LIST...)"
     198           0 :   (apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest)))
     199             : 
     200             : ;;;###autoload
     201             : (defun cl-some (cl-pred cl-seq &rest cl-rest)
     202             :   "Return true if PREDICATE is true of any element of SEQ or SEQs.
     203             : If so, return the true (non-nil) value returned by PREDICATE.
     204             : \n(fn PREDICATE SEQ...)"
     205           0 :   (if (or cl-rest (nlistp cl-seq))
     206           0 :       (catch 'cl-some
     207           0 :         (apply 'cl-map nil
     208           0 :                (function (lambda (&rest cl-x)
     209           0 :                            (let ((cl-res (apply cl-pred cl-x)))
     210           0 :                              (if cl-res (throw 'cl-some cl-res)))))
     211           0 :                cl-seq cl-rest) nil)
     212           0 :     (let ((cl-x nil))
     213           0 :       (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq))))))
     214           0 :       cl-x)))
     215             : 
     216             : ;;;###autoload
     217             : (defun cl-every (cl-pred cl-seq &rest cl-rest)
     218             :   "Return true if PREDICATE is true of every element of SEQ or SEQs.
     219             : \n(fn PREDICATE SEQ...)"
     220           0 :   (if (or cl-rest (nlistp cl-seq))
     221           0 :       (catch 'cl-every
     222           0 :         (apply 'cl-map nil
     223           0 :                (function (lambda (&rest cl-x)
     224           0 :                            (or (apply cl-pred cl-x) (throw 'cl-every nil))))
     225           0 :                cl-seq cl-rest) t)
     226           0 :     (while (and cl-seq (funcall cl-pred (car cl-seq)))
     227           0 :       (setq cl-seq (cdr cl-seq)))
     228           0 :     (null cl-seq)))
     229             : 
     230             : ;;;###autoload
     231             : (defun cl-notany (cl-pred cl-seq &rest cl-rest)
     232             :   "Return true if PREDICATE is false of every element of SEQ or SEQs.
     233             : \n(fn PREDICATE SEQ...)"
     234           0 :   (not (apply 'cl-some cl-pred cl-seq cl-rest)))
     235             : 
     236             : ;;;###autoload
     237             : (defun cl-notevery (cl-pred cl-seq &rest cl-rest)
     238             :   "Return true if PREDICATE is false of some element of SEQ or SEQs.
     239             : \n(fn PREDICATE SEQ...)"
     240           0 :   (not (apply 'cl-every cl-pred cl-seq cl-rest)))
     241             : 
     242             : ;;;###autoload
     243             : (defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
     244           0 :   (or cl-base
     245           0 :       (setq cl-base (copy-sequence [0])))
     246           0 :   (map-keymap
     247           0 :    (function
     248             :     (lambda (cl-key cl-bind)
     249           0 :       (aset cl-base (1- (length cl-base)) cl-key)
     250           0 :       (if (keymapp cl-bind)
     251           0 :           (cl--map-keymap-recursively
     252           0 :            cl-func-rec cl-bind
     253           0 :            (vconcat cl-base (list 0)))
     254           0 :         (funcall cl-func-rec cl-base cl-bind))))
     255           0 :    cl-map))
     256             : 
     257             : ;;;###autoload
     258             : (defun cl--map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
     259           0 :   (or cl-what (setq cl-what (current-buffer)))
     260           0 :   (if (bufferp cl-what)
     261           0 :       (let (cl-mark cl-mark2 (cl-next t) cl-next2)
     262           0 :         (with-current-buffer cl-what
     263           0 :           (setq cl-mark (copy-marker (or cl-start (point-min))))
     264           0 :           (setq cl-mark2 (and cl-end (copy-marker cl-end))))
     265           0 :         (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
     266           0 :           (setq cl-next (if cl-prop (next-single-property-change
     267           0 :                                      cl-mark cl-prop cl-what)
     268           0 :                           (next-property-change cl-mark cl-what))
     269           0 :                 cl-next2 (or cl-next (with-current-buffer cl-what
     270           0 :                                        (point-max))))
     271           0 :           (funcall cl-func (prog1 (marker-position cl-mark)
     272           0 :                              (set-marker cl-mark cl-next2))
     273           0 :                    (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
     274           0 :         (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
     275           0 :     (or cl-start (setq cl-start 0))
     276           0 :     (or cl-end (setq cl-end (length cl-what)))
     277           0 :     (while (< cl-start cl-end)
     278           0 :       (let ((cl-next (or (if cl-prop (next-single-property-change
     279           0 :                                       cl-start cl-prop cl-what)
     280           0 :                            (next-property-change cl-start cl-what))
     281           0 :                          cl-end)))
     282           0 :         (funcall cl-func cl-start (min cl-next cl-end))
     283           0 :         (setq cl-start cl-next)))))
     284             : 
     285             : ;;;###autoload
     286             : (defun cl--map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
     287           0 :   (or cl-buffer (setq cl-buffer (current-buffer)))
     288           0 :   (let (cl-ovl)
     289           0 :     (with-current-buffer cl-buffer
     290           0 :       (setq cl-ovl (overlay-lists))
     291           0 :       (if cl-start (setq cl-start (copy-marker cl-start)))
     292           0 :       (if cl-end (setq cl-end (copy-marker cl-end))))
     293           0 :     (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
     294           0 :     (while (and cl-ovl
     295           0 :                 (or (not (overlay-start (car cl-ovl)))
     296           0 :                     (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
     297           0 :                     (and cl-start (<= (overlay-end (car cl-ovl)) cl-start))
     298           0 :                     (not (funcall cl-func (car cl-ovl) cl-arg))))
     299           0 :       (setq cl-ovl (cdr cl-ovl)))
     300           0 :     (if cl-start (set-marker cl-start nil))
     301           0 :     (if cl-end (set-marker cl-end nil))))
     302             : 
     303             : ;;; Support for `setf'.
     304             : ;;;###autoload
     305             : (defun cl--set-frame-visible-p (frame val)
     306           0 :   (cond ((null val) (make-frame-invisible frame))
     307           0 :         ((eq val 'icon) (iconify-frame frame))
     308           0 :         (t (make-frame-visible frame)))
     309           0 :   val)
     310             : 
     311             : 
     312             : ;;; Numbers.
     313             : 
     314             : ;;;###autoload
     315             : (defun cl-gcd (&rest args)
     316             :   "Return the greatest common divisor of the arguments."
     317           0 :   (let ((a (or (pop args) 0)))
     318           0 :     (dolist (b args)
     319           0 :       (while (/= b 0)
     320           0 :         (setq b (% a (setq a b)))))
     321           0 :     (abs a)))
     322             : 
     323             : ;;;###autoload
     324             : (defun cl-lcm (&rest args)
     325             :   "Return the least common multiple of the arguments."
     326           0 :   (if (memq 0 args)
     327             :       0
     328           0 :     (let ((a (or (pop args) 1)))
     329           0 :       (dolist (b args)
     330           0 :         (setq a (* (/ a (cl-gcd a b)) b)))
     331           0 :       (abs a))))
     332             : 
     333             : ;;;###autoload
     334             : (defun cl-isqrt (x)
     335             :   "Return the integer square root of the argument."
     336           0 :   (if (and (integerp x) (> x 0))
     337           0 :       (let ((g (cond ((<= x 100) 10) ((<= x 10000) 100)
     338           0 :                      ((<= x 1000000) 1000) (t x)))
     339             :             g2)
     340           0 :         (while (< (setq g2 (/ (+ g (/ x g)) 2)) g)
     341           0 :           (setq g g2))
     342           0 :         g)
     343           0 :     (if (eq x 0) 0 (signal 'arith-error nil))))
     344             : 
     345             : ;;;###autoload
     346             : (defun cl-floor (x &optional y)
     347             :   "Return a list of the floor of X and the fractional part of X.
     348             : With two arguments, return floor and remainder of their quotient."
     349           0 :   (let ((q (floor x y)))
     350           0 :     (list q (- x (if y (* y q) q)))))
     351             : 
     352             : ;;;###autoload
     353             : (defun cl-ceiling (x &optional y)
     354             :   "Return a list of the ceiling of X and the fractional part of X.
     355             : With two arguments, return ceiling and remainder of their quotient."
     356           0 :   (let ((res (cl-floor x y)))
     357           0 :     (if (= (car (cdr res)) 0) res
     358           0 :       (list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
     359             : 
     360             : ;;;###autoload
     361             : (defun cl-truncate (x &optional y)
     362             :   "Return a list of the integer part of X and the fractional part of X.
     363             : With two arguments, return truncation and remainder of their quotient."
     364           0 :   (if (eq (>= x 0) (or (null y) (>= y 0)))
     365           0 :       (cl-floor x y) (cl-ceiling x y)))
     366             : 
     367             : ;;;###autoload
     368             : (defun cl-round (x &optional y)
     369             :   "Return a list of X rounded to the nearest integer and the remainder.
     370             : With two arguments, return rounding and remainder of their quotient."
     371           0 :   (if y
     372           0 :       (if (and (integerp x) (integerp y))
     373           0 :           (let* ((hy (/ y 2))
     374           0 :                  (res (cl-floor (+ x hy) y)))
     375           0 :             (if (and (= (car (cdr res)) 0)
     376           0 :                      (= (+ hy hy) y)
     377           0 :                      (/= (% (car res) 2) 0))
     378           0 :                 (list (1- (car res)) hy)
     379           0 :               (list (car res) (- (car (cdr res)) hy))))
     380           0 :         (let ((q (round (/ x y))))
     381           0 :           (list q (- x (* q y)))))
     382           0 :     (if (integerp x) (list x 0)
     383           0 :       (let ((q (round x)))
     384           0 :         (list q (- x q))))))
     385             : 
     386             : ;;;###autoload
     387             : (defun cl-mod (x y)
     388             :   "The remainder of X divided by Y, with the same sign as Y."
     389           0 :   (nth 1 (cl-floor x y)))
     390             : 
     391             : ;;;###autoload
     392             : (defun cl-rem (x y)
     393             :   "The remainder of X divided by Y, with the same sign as X."
     394           0 :   (nth 1 (cl-truncate x y)))
     395             : 
     396             : ;;;###autoload
     397             : (defun cl-signum (x)
     398             :   "Return 1 if X is positive, -1 if negative, 0 if zero."
     399           0 :   (cond ((> x 0) 1) ((< x 0) -1) (t 0)))
     400             : 
     401             : ;;;###autoload
     402             : (cl-defun cl-parse-integer (string &key start end radix junk-allowed)
     403             :   "Parse integer from the substring of STRING from START to END.
     404             : STRING may be surrounded by whitespace chars (chars with syntax ` ').
     405             : Other non-digit chars are considered junk.
     406             : RADIX is an integer between 2 and 36, the default is 10.  Signal
     407             : an error if the substring between START and END cannot be parsed
     408             : as an integer unless JUNK-ALLOWED is non-nil."
     409           0 :   (cl-check-type string string)
     410           0 :   (let* ((start (or start 0))
     411           0 :          (len   (length string))
     412           0 :          (end   (or end len))
     413           0 :          (radix (or radix 10)))
     414           0 :     (or (<= start end len)
     415           0 :         (error "Bad interval: [%d, %d)" start end))
     416           0 :     (cl-flet ((skip-whitespace ()
     417           0 :                 (while (and (< start end)
     418           0 :                             (= 32 (char-syntax (aref string start))))
     419           0 :                   (setq start (1+ start)))))
     420           0 :       (skip-whitespace)
     421           0 :       (let ((sign (cl-case (and (< start end) (aref string start))
     422           0 :                     (?+ (cl-incf start) +1)
     423           0 :                     (?- (cl-incf start) -1)
     424           0 :                     (t  +1)))
     425             :             digit sum)
     426           0 :         (while (and (< start end)
     427           0 :                     (setq digit (cl-digit-char-p (aref string start) radix)))
     428           0 :           (setq sum (+ (* (or sum 0) radix) digit)
     429           0 :                 start (1+ start)))
     430           0 :         (skip-whitespace)
     431           0 :         (cond ((and junk-allowed (null sum)) sum)
     432           0 :               (junk-allowed (* sign sum))
     433           0 :               ((or (/= start end) (null sum))
     434           0 :                (error "Not an integer string: `%s'" string))
     435           0 :               (t (* sign sum)))))))
     436             : 
     437             : 
     438             : ;; Random numbers.
     439             : 
     440             : (defun cl--random-time ()
     441           0 :   (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
     442           0 :     (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
     443           0 :     v))
     444             : 
     445             : ;;;###autoload (autoload 'cl-random-state-p "cl-extra")
     446             : (cl-defstruct (cl--random-state
     447             :                (:copier nil)
     448             :                (:predicate cl-random-state-p)
     449             :                (:constructor nil)
     450             :                (:constructor cl--make-random-state (vec)))
     451             :   (i -1) (j 30) vec)
     452             : 
     453             : (defvar cl--random-state (cl--make-random-state (cl--random-time)))
     454             : 
     455             : ;;;###autoload
     456             : (defun cl-random (lim &optional state)
     457             :   "Return a random nonnegative number less than LIM, an integer or float.
     458             : Optional second arg STATE is a random-state object."
     459           0 :   (or state (setq state cl--random-state))
     460             :   ;; Inspired by "ran3" from Numerical Recipes.  Additive congruential method.
     461           0 :   (let ((vec (cl--random-state-vec state)))
     462           0 :     (if (integerp vec)
     463           0 :         (let ((i 0) (j (- 1357335 (abs (% vec 1357333)))) (k 1))
     464           0 :           (setf (cl--random-state-vec state)
     465           0 :                 (setq vec (make-vector 55 nil)))
     466           0 :           (aset vec 0 j)
     467           0 :           (while (> (setq i (% (+ i 21) 55)) 0)
     468           0 :             (aset vec i (setq j (prog1 k (setq k (- j k))))))
     469           0 :           (while (< (setq i (1+ i)) 200) (cl-random 2 state))))
     470           0 :     (let* ((i (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-i state)))
     471           0 :            (j (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-j state)))
     472           0 :            (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
     473           0 :       (if (integerp lim)
     474           0 :           (if (<= lim 512) (% n lim)
     475           0 :             (if (> lim 8388607) (setq n (+ (lsh n 9) (cl-random 512 state))))
     476           0 :             (let ((mask 1023))
     477           0 :               (while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
     478           0 :               (if (< (setq n (logand n mask)) lim) n (cl-random lim state))))
     479           0 :         (* (/ n '8388608e0) lim)))))
     480             : 
     481             : ;;;###autoload
     482             : (defun cl-make-random-state (&optional state)
     483             :   "Return a copy of random-state STATE, or of the internal state if omitted.
     484             : If STATE is t, return a new state object seeded from the time of day."
     485           0 :   (unless state (setq state cl--random-state))
     486           0 :   (if (cl-random-state-p state)
     487           0 :       (copy-tree state t)
     488           0 :     (cl--make-random-state (if (integerp state) state (cl--random-time)))))
     489             : 
     490             : ;; Implementation limits.
     491             : 
     492             : (defun cl--finite-do (func a b)
     493           0 :   (condition-case _
     494           0 :       (let ((res (funcall func a b)))   ; check for IEEE infinity
     495           0 :         (and (numberp res) (/= res (/ res 2)) res))
     496           0 :     (arith-error nil)))
     497             : 
     498             : ;;;###autoload
     499             : (defun cl-float-limits ()
     500             :   "Initialize the Common Lisp floating-point parameters.
     501             : This sets the values of: `cl-most-positive-float', `cl-most-negative-float',
     502             : `cl-least-positive-float', `cl-least-negative-float', `cl-float-epsilon',
     503             : `cl-float-negative-epsilon', `cl-least-positive-normalized-float', and
     504             : `cl-least-negative-normalized-float'."
     505           0 :   (or cl-most-positive-float (not (numberp '2e1))
     506           0 :       (let ((x '2e0) y z)
     507             :         ;; Find maximum exponent (first two loops are optimizations)
     508           0 :         (while (cl--finite-do '* x x) (setq x (* x x)))
     509           0 :         (while (cl--finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
     510           0 :         (while (cl--finite-do '+ x x) (setq x (+ x x)))
     511           0 :         (setq z x y (/ x 2))
     512             :         ;; Now cl-fill in 1's in the mantissa.
     513           0 :         (while (and (cl--finite-do '+ x y) (/= (+ x y) x))
     514           0 :           (setq x (+ x y) y (/ y 2)))
     515           0 :         (setq cl-most-positive-float x
     516           0 :               cl-most-negative-float (- x))
     517             :         ;; Divide down until mantissa starts rounding.
     518           0 :         (setq x (/ x z) y (/ 16 z) x (* x y))
     519           0 :         (while (condition-case _ (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
     520           0 :                  (arith-error nil))
     521           0 :           (setq x (/ x 2) y (/ y 2)))
     522           0 :         (setq cl-least-positive-normalized-float y
     523           0 :               cl-least-negative-normalized-float (- y))
     524             :         ;; Divide down until value underflows to zero.
     525           0 :         (setq x (/ z) y x)
     526           0 :         (while (condition-case _ (> (/ x 2) 0) (arith-error nil))
     527           0 :           (setq x (/ x 2)))
     528           0 :         (setq cl-least-positive-float x
     529           0 :               cl-least-negative-float (- x))
     530           0 :         (setq x '1e0)
     531           0 :         (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2)))
     532           0 :         (setq cl-float-epsilon (* x 2))
     533           0 :         (setq x '1e0)
     534           0 :         (while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
     535           0 :         (setq cl-float-negative-epsilon (* x 2))))
     536             :   nil)
     537             : 
     538             : 
     539             : ;;; Sequence functions.
     540             : 
     541             : ;;;###autoload
     542             : (defun cl-subseq (seq start &optional end)
     543             :   "Return the subsequence of SEQ from START to END.
     544             : If END is omitted, it defaults to the length of the sequence.
     545             : If START or END is negative, it counts from the end.
     546             : Signal an error if START or END are outside of the sequence (i.e
     547             : too large if positive or too small if negative)."
     548             :   (declare (gv-setter
     549             :             (lambda (new)
     550             :               (macroexp-let2 nil new new
     551             :                 `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
     552             :                         ,new)))))
     553           2 :   (cond ((or (stringp seq) (vectorp seq)) (substring seq start end))
     554           2 :         ((listp seq)
     555           2 :          (let (len
     556           2 :                (errtext (format "Bad bounding indices: %s, %s" start end)))
     557           2 :            (and end (< end 0) (setq end (+ end (setq len (length seq)))))
     558           2 :            (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
     559           2 :            (unless (>= start 0)
     560           2 :              (error "%s" errtext))
     561           2 :            (when (> start 0)
     562           0 :              (setq seq (nthcdr (1- start) seq))
     563           0 :              (or seq (error "%s" errtext))
     564           2 :              (setq seq (cdr seq)))
     565           2 :            (if end
     566           2 :                (let ((res nil))
     567          24 :                  (while (and (>= (setq end (1- end)) start) seq)
     568          44 :                    (push (pop seq) res))
     569           2 :                  (or (= (1+ end) start) (error "%s" errtext))
     570           2 :                  (nreverse res))
     571           2 :              (copy-sequence seq))))
     572           2 :         (t (error "Unsupported sequence: %s" seq))))
     573             : 
     574             : ;;;###autoload
     575             : (defun cl-concatenate (type &rest sequences)
     576             :   "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
     577             : \n(fn TYPE SEQUENCE...)"
     578           0 :   (pcase type
     579           0 :     (`vector (apply #'vconcat sequences))
     580           0 :     (`string (apply #'concat sequences))
     581           0 :     (`list (apply #'append (append sequences '(nil))))
     582           0 :     (_ (error "Not a sequence type name: %S" type))))
     583             : 
     584             : ;;; List functions.
     585             : 
     586             : ;;;###autoload
     587             : (defun cl-revappend (x y)
     588             :   "Equivalent to (append (reverse X) Y)."
     589           0 :   (nconc (reverse x) y))
     590             : 
     591             : ;;;###autoload
     592             : (defun cl-nreconc (x y)
     593             :   "Equivalent to (nconc (nreverse X) Y)."
     594           0 :   (nconc (nreverse x) y))
     595             : 
     596             : ;;;###autoload
     597             : (defun cl-list-length (x)
     598             :   "Return the length of list X.  Return nil if list is circular."
     599           0 :   (let ((n 0) (fast x) (slow x))
     600           0 :     (while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
     601           0 :       (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))
     602           0 :     (if fast (if (cdr fast) nil (1+ n)) n)))
     603             : 
     604             : ;;;###autoload
     605             : (defun cl-tailp (sublist list)
     606             :   "Return true if SUBLIST is a tail of LIST."
     607           0 :   (while (and (consp list) (not (eq sublist list)))
     608           0 :     (setq list (cdr list)))
     609           0 :   (if (numberp sublist) (equal sublist list) (eq sublist list)))
     610             : 
     611             : ;;; Property lists.
     612             : 
     613             : ;;;###autoload
     614             : (defun cl-get (sym tag &optional def)
     615             :   "Return the value of SYMBOL's PROPNAME property, or DEFAULT if none.
     616             : \n(fn SYMBOL PROPNAME &optional DEFAULT)"
     617             :   (declare (compiler-macro cl--compiler-macro-get)
     618             :            (gv-setter (lambda (store) (ignore def) `(put ,sym ,tag ,store))))
     619           0 :   (cl-getf (symbol-plist sym) tag def))
     620             : (autoload 'cl--compiler-macro-get "cl-macs")
     621             : 
     622             : ;;;###autoload
     623             : (defun cl-getf (plist tag &optional def)
     624             :   "Search PROPLIST for property PROPNAME; return its value or DEFAULT.
     625             : PROPLIST is a list of the sort returned by `symbol-plist'.
     626             : \n(fn PROPLIST PROPNAME &optional DEFAULT)"
     627             :   (declare (gv-expander
     628             :             (lambda (do)
     629             :               (gv-letplace (getter setter) plist
     630             :                 (macroexp-let2* nil ((k tag) (d def))
     631             :                   (funcall do `(cl-getf ,getter ,k ,d)
     632             :                            (lambda (v)
     633             :                              (macroexp-let2 nil val v
     634             :                                `(progn
     635             :                                   ,(funcall setter
     636             :                                             `(cl--set-getf ,getter ,k ,val))
     637             :                                   ,val)))))))))
     638           0 :   (let ((val-tail (cdr-safe (plist-member plist tag))))
     639           0 :     (if val-tail (car val-tail) def)))
     640             : 
     641             : ;;;###autoload
     642             : (defun cl--set-getf (plist tag val)
     643           0 :   (let ((val-tail (cdr-safe (plist-member plist tag))))
     644           0 :     (if val-tail (progn (setcar val-tail val) plist)
     645           0 :       (cl-list* tag val plist))))
     646             : 
     647             : ;;;###autoload
     648             : (defun cl--do-remf (plist tag)
     649           0 :   (let ((p (cdr plist)))
     650             :     ;; Can't use `plist-member' here because it goes to the cons-cell
     651             :     ;; of TAG and we need the one before.
     652           0 :     (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
     653           0 :     (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
     654             : 
     655             : ;;;###autoload
     656             : (defun cl-remprop (sym tag)
     657             :   "Remove from SYMBOL's plist the property PROPNAME and its value.
     658             : \n(fn SYMBOL PROPNAME)"
     659           0 :   (let ((plist (symbol-plist sym)))
     660           0 :     (if (and plist (eq tag (car plist)))
     661           0 :         (progn (setplist sym (cdr (cdr plist))) t)
     662           0 :       (cl--do-remf plist tag))))
     663             : 
     664             : ;;; Streams.
     665             : 
     666             : ;;;###autoload
     667             : (defun cl-fresh-line (&optional stream)
     668             :   "Output a newline unless already at the beginning of a line."
     669           0 :   (terpri stream 'ensure))
     670             : 
     671             : ;;; Some debugging aids.
     672             : 
     673             : (defun cl-prettyprint (form)
     674             :   "Insert a pretty-printed rendition of a Lisp FORM in current buffer."
     675           0 :   (let ((pt (point)) last)
     676           0 :     (insert "\n" (prin1-to-string form) "\n")
     677           0 :     (setq last (point))
     678           0 :     (goto-char (1+ pt))
     679           0 :     (while (search-forward "(quote " last t)
     680           0 :       (delete-char -7)
     681           0 :       (insert "'")
     682           0 :       (forward-sexp)
     683           0 :       (delete-char 1))
     684           0 :     (goto-char (1+ pt))
     685           0 :     (cl--do-prettyprint)))
     686             : 
     687             : (defun cl--do-prettyprint ()
     688           0 :   (skip-chars-forward " ")
     689           0 :   (if (looking-at "(")
     690           0 :       (let ((skip (or (looking-at "((") (looking-at "(prog")
     691           0 :                       (looking-at "(unwind-protect ")
     692           0 :                       (looking-at "(function (")
     693           0 :                       (looking-at "(cl--block-wrapper ")))
     694           0 :             (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
     695           0 :             (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
     696           0 :             (set (looking-at "(p?set[qf] ")))
     697           0 :         (if (or skip let
     698           0 :                 (progn
     699           0 :                   (forward-sexp)
     700           0 :                   (and (>= (current-column) 78) (progn (backward-sexp) t))))
     701           0 :             (let ((nl t))
     702           0 :               (forward-char 1)
     703           0 :               (cl--do-prettyprint)
     704           0 :               (or skip (looking-at ")") (cl--do-prettyprint))
     705           0 :               (or (not two) (looking-at ")") (cl--do-prettyprint))
     706           0 :               (while (not (looking-at ")"))
     707           0 :                 (if set (setq nl (not nl)))
     708           0 :                 (if nl (insert "\n"))
     709           0 :                 (lisp-indent-line)
     710           0 :                 (cl--do-prettyprint))
     711           0 :               (forward-char 1))))
     712           0 :     (forward-sexp)))
     713             : 
     714             : ;;;###autoload
     715             : (defun cl-prettyexpand (form &optional full)
     716             :   "Expand macros in FORM and insert the pretty-printed result.
     717             : Optional argument FULL non-nil means to expand all macros,
     718             : including `cl-block' and `cl-eval-when'."
     719           0 :   (message "Expanding...")
     720           0 :   (let ((cl--compiling-file full)
     721             :         (byte-compile-macro-environment nil))
     722           0 :     (setq form (macroexpand-all form
     723           0 :                                 (and (not full) '((cl-block) (cl-eval-when)))))
     724           0 :     (message "Formatting...")
     725           0 :     (prog1 (cl-prettyprint form)
     726           0 :       (message ""))))
     727             : 
     728             : ;;; Integration into the online help system.
     729             : 
     730             : (eval-when-compile (require 'cl-macs))  ;Explicitly, for cl--find-class.
     731             : (require 'help-mode)
     732             : 
     733             : ;; FIXME: We could go crazy and add another entry so describe-symbol can be
     734             : ;; used with the slot names of CL structs (and/or EIEIO objects).
     735             : (add-to-list 'describe-symbol-backends
     736             :              `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s))))
     737             : 
     738             : (defconst cl--typedef-regexp
     739             :   (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct"
     740             :                             "cl-deftype" "deftype"))
     741             :           "[ \t\r\n]+%s[ \t\r\n]+"))
     742             : (with-eval-after-load 'find-func
     743             :   (defvar find-function-regexp-alist)
     744             :   (add-to-list 'find-function-regexp-alist
     745             :                `(define-type . cl--typedef-regexp)))
     746             : 
     747             : (define-button-type 'cl-help-type
     748             :   :supertype 'help-function-def
     749             :   'help-function #'cl-describe-type
     750             :   'help-echo (purecopy "mouse-2, RET: describe this type"))
     751             : 
     752             : (define-button-type 'cl-type-definition
     753             :   :supertype 'help-function-def
     754             :   'help-echo (purecopy "mouse-2, RET: find type definition"))
     755             : 
     756             : (declare-function help-fns-short-filename "help-fns" (filename))
     757             : 
     758             : ;;;###autoload
     759           0 : (defun cl-find-class (type) (cl--find-class type))
     760             : 
     761             : ;;;###autoload
     762             : (defun cl-describe-type (type)
     763             :   "Display the documentation for type TYPE (a symbol)."
     764             :   (interactive
     765           0 :    (let ((str (completing-read "Describe type: " obarray #'cl-find-class t)))
     766           0 :      (if (<= (length str) 0)
     767           0 :          (user-error "Abort!")
     768           0 :        (list (intern str)))))
     769           0 :   (help-setup-xref (list #'cl-describe-type type)
     770           0 :                    (called-interactively-p 'interactive))
     771           0 :   (save-excursion
     772           0 :     (with-help-window (help-buffer)
     773           0 :       (with-current-buffer standard-output
     774           0 :         (let ((class (cl-find-class type)))
     775           0 :           (if class
     776           0 :               (cl--describe-class type class)
     777             :             ;; FIXME: Describe other types (the built-in ones, or those from
     778             :             ;; cl-deftype).
     779           0 :             (user-error "Unknown type %S" type))))
     780           0 :       (with-current-buffer standard-output
     781             :         ;; Return the text we displayed.
     782           0 :         (buffer-string)))))
     783             : 
     784             : (defun cl--describe-class (type &optional class)
     785           0 :   (unless class (setq class (cl--find-class type)))
     786           0 :   (let ((location (find-lisp-object-file-name type 'define-type))
     787           0 :         (metatype (type-of class)))
     788           0 :     (insert (symbol-name type)
     789           0 :             (substitute-command-keys " is a type (of kind `"))
     790           0 :     (help-insert-xref-button (symbol-name metatype)
     791           0 :                              'cl-help-type metatype)
     792           0 :     (insert (substitute-command-keys "')"))
     793           0 :     (when location
     794           0 :       (insert (substitute-command-keys " in `"))
     795           0 :       (help-insert-xref-button
     796           0 :        (help-fns-short-filename location)
     797           0 :        'cl-type-definition type location 'define-type)
     798           0 :       (insert (substitute-command-keys "'")))
     799           0 :     (insert ".\n")
     800             : 
     801             :     ;; Parents.
     802           0 :     (let ((pl (cl--class-parents class))
     803             :           cur)
     804           0 :       (when pl
     805           0 :         (insert " Inherits from ")
     806           0 :         (while (setq cur (pop pl))
     807           0 :           (setq cur (cl--class-name cur))
     808           0 :           (insert (substitute-command-keys "`"))
     809           0 :           (help-insert-xref-button (symbol-name cur)
     810           0 :                                    'cl-help-type cur)
     811           0 :           (insert (substitute-command-keys (if pl "', " "'"))))
     812           0 :         (insert ".\n")))
     813             : 
     814             :     ;; Children, if available.  ¡For EIEIO!
     815           0 :     (let ((ch (condition-case nil
     816           0 :                   (cl-struct-slot-value metatype 'children class)
     817           0 :                 (cl-struct-unknown-slot nil)))
     818             :           cur)
     819           0 :       (when ch
     820           0 :         (insert " Children ")
     821           0 :         (while (setq cur (pop ch))
     822           0 :           (insert (substitute-command-keys "`"))
     823           0 :           (help-insert-xref-button (symbol-name cur)
     824           0 :                                    'cl-help-type cur)
     825           0 :           (insert (substitute-command-keys (if ch "', " "'"))))
     826           0 :         (insert ".\n")))
     827             : 
     828             :     ;; Type's documentation.
     829           0 :     (let ((doc (cl--class-docstring class)))
     830           0 :       (when doc
     831           0 :         (insert "\n" doc "\n\n")))
     832             : 
     833             :     ;; Describe all the slots in this class.
     834           0 :     (cl--describe-class-slots class)
     835             : 
     836             :     ;; Describe all the methods specific to this class.
     837           0 :     (let ((generics (cl-generic-all-functions type)))
     838           0 :       (when generics
     839           0 :         (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
     840           0 :         (dolist (generic generics)
     841           0 :           (insert (substitute-command-keys "`"))
     842           0 :           (help-insert-xref-button (symbol-name generic)
     843           0 :                                    'help-function generic)
     844           0 :           (insert (substitute-command-keys "'"))
     845           0 :           (pcase-dolist (`(,qualifiers ,args ,doc)
     846           0 :                          (cl--generic-method-documentation generic type))
     847           0 :             (insert (format " %s%S\n" qualifiers args)
     848           0 :                     (or doc "")))
     849           0 :           (insert "\n\n"))))))
     850             : 
     851             : (defun cl--describe-class-slot (slot)
     852           0 :   (insert
     853           0 :    (concat
     854           0 :     (propertize "Slot: " 'face 'bold)
     855           0 :     (prin1-to-string (cl--slot-descriptor-name slot))
     856           0 :     (unless (eq (cl--slot-descriptor-type slot) t)
     857           0 :       (concat "    type = "
     858           0 :               (prin1-to-string (cl--slot-descriptor-type slot))))
     859             :     ;; FIXME: The default init form is treated differently for structs and for
     860             :     ;; eieio objects: for structs, the default is nil, for eieio-objects
     861             :     ;; it's a special "unbound" value.
     862           0 :     (unless nil ;; (eq (cl--slot-descriptor-initform slot) eieio-unbound)
     863           0 :       (concat "    default = "
     864           0 :               (prin1-to-string (cl--slot-descriptor-initform slot))))
     865           0 :     (when (alist-get :printer (cl--slot-descriptor-props slot))
     866           0 :       (concat "    printer = "
     867           0 :               (prin1-to-string
     868           0 :                (alist-get :printer (cl--slot-descriptor-props slot)))))
     869           0 :     (when (alist-get :documentation (cl--slot-descriptor-props slot))
     870           0 :       (concat "\n  "
     871           0 :               (substitute-command-keys
     872           0 :                (alist-get :documentation (cl--slot-descriptor-props slot)))
     873           0 :               "\n")))
     874           0 :    "\n"))
     875             : 
     876             : (defun cl--print-table (header rows)
     877             :   ;; FIXME: Isn't this functionality already implemented elsewhere?
     878           0 :   (let ((cols (apply #'vector (mapcar #'string-width header)))
     879             :         (col-space 2))
     880           0 :     (dolist (row rows)
     881           0 :       (dotimes (i (length cols))
     882           0 :         (let* ((x (pop row))
     883           0 :                (curwidth (aref cols i))
     884           0 :                (newwidth (if x (string-width x) 0)))
     885           0 :           (if (> newwidth curwidth)
     886           0 :               (setf (aref cols i) newwidth)))))
     887           0 :     (let ((formats '())
     888             :           (col 0))
     889           0 :       (dotimes (i (length cols))
     890           0 :         (push (concat (propertize "        "
     891             :                                   'display
     892           0 :                                   `(space :align-to ,(+ col col-space)))
     893           0 :                       "%s")
     894           0 :               formats)
     895           0 :         (cl-incf col (+ col-space (aref cols i))))
     896           0 :       (let ((format (mapconcat #'identity (nreverse formats) "")))
     897           0 :         (insert (apply #'format format
     898           0 :                        (mapcar (lambda (str) (propertize str 'face 'italic))
     899           0 :                                header))
     900           0 :                 "\n")
     901           0 :         (insert (apply #'format format
     902           0 :                        (mapcar (lambda (str) (make-string (string-width str) ?—))
     903           0 :                                header))
     904           0 :                 "\n")
     905           0 :         (dolist (row rows)
     906           0 :           (insert (apply #'format format row) "\n"))))))
     907             : 
     908             : (defun cl--describe-class-slots (class)
     909             :   "Print help description for the slots in CLASS.
     910             : Outputs to the current buffer."
     911           0 :   (let* ((slots (cl--class-slots class))
     912           0 :          (metatype (type-of class))
     913             :          ;; ¡For EIEIO!
     914           0 :          (cslots (condition-case nil
     915           0 :                      (cl-struct-slot-value metatype 'class-slots class)
     916           0 :                    (cl-struct-unknown-slot nil))))
     917           0 :     (insert (propertize "Instance Allocated Slots:\n\n"
     918           0 :                         'face 'bold))
     919           0 :     (let* ((has-doc nil)
     920             :            (slots-strings
     921           0 :             (mapcar
     922             :              (lambda (slot)
     923           0 :                (list (cl-prin1-to-string (cl--slot-descriptor-name slot))
     924           0 :                      (cl-prin1-to-string (cl--slot-descriptor-type slot))
     925           0 :                      (cl-prin1-to-string (cl--slot-descriptor-initform slot))
     926           0 :                      (let ((doc (alist-get :documentation
     927           0 :                                            (cl--slot-descriptor-props slot))))
     928           0 :                        (if (not doc) ""
     929           0 :                          (setq has-doc t)
     930           0 :                          (substitute-command-keys doc)))))
     931           0 :              slots)))
     932           0 :       (cl--print-table `("Name" "Type" "Default" . ,(if has-doc '("Doc")))
     933           0 :                        slots-strings))
     934           0 :     (insert "\n")
     935           0 :     (when (> (length cslots) 0)
     936           0 :       (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))
     937           0 :       (mapc #'cl--describe-class-slot cslots))))
     938             : 
     939             : 
     940             : (run-hooks 'cl-extra-load-hook)
     941             : 
     942             : ;; Local variables:
     943             : ;; byte-compile-dynamic: t
     944             : ;; generated-autoload-file: "cl-loaddefs.el"
     945             : ;; End:
     946             : 
     947             : (provide 'cl-extra)
     948             : ;;; cl-extra.el ends here

Generated by: LCOV version 1.12